commit c101616e6246a275c6c30ea0175f2f069e7a54ff Author: La Ancapo <> Date: Sun Jan 25 02:27:22 2026 +0100 Initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..858de7d --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +cabal.project.local +dist-newstyle/ +*.sw? diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..958c903 --- /dev/null +++ b/COPYING @@ -0,0 +1,15 @@ +Stellar Veritas is released under the terms of GNU AFFERO GENERAL PUBLIC LICENSE Version 3. + +Following bundled libraries are released under their corresponding licenses as published on Hackage: +base32 +base64-bytestring +cereal +ed25519 +scientific +stellar-sdk +stellar-horizon +SHA +integer-logarithms +cryptonite +memory +basement diff --git a/README.md b/README.md new file mode 100644 index 0000000..96fcf66 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +# Stellar Veritas + +The aim is to create a trustworthy Stellar transaction signer (and, by necessity, a pretty printer) using only Glasgow Haskell compiler code and Haskell Core libraries, reducing the possible supply chain attack surface. + +To build and run it, install `cabal-install` and use `cabal run`. + +The project contains the code of trimmed-down non-core dependencies, mainly cryptographic libraries. To avoid using bundled libraries (to build against the current Hackage), do the same in the `src` directory. To further reduce the amount of code under audit, weeder can be used, although the utility is dubious. diff --git a/bundled/Basement/Alg/Class.hs b/bundled/Basement/Alg/Class.hs new file mode 100644 index 0000000..d702d87 --- /dev/null +++ b/bundled/Basement/Alg/Class.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Basement.Alg.Class + ( Indexable, index + , RandomAccess, read, write + ) where + +import Basement.Types.OffsetSize + +class Indexable container ty where + index :: container -> (Offset ty) -> ty + +class RandomAccess container prim ty where + read :: container -> (Offset ty) -> prim ty + write :: container -> (Offset ty) -> ty -> prim () diff --git a/bundled/Basement/Alg/Mutable.hs b/bundled/Basement/Alg/Mutable.hs new file mode 100644 index 0000000..ec00bba --- /dev/null +++ b/bundled/Basement/Alg/Mutable.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Basement.Alg.Mutable + ( inplaceSortBy + ) where + +import GHC.Types +import GHC.Prim +import Basement.Compat.Base +import Basement.Numerical.Additive +import Basement.Numerical.Multiplicative +import Basement.Types.OffsetSize +import Basement.PrimType +import Basement.Monad +import Basement.Alg.Class + +inplaceSortBy :: (PrimMonad prim, RandomAccess container prim ty) + => (ty -> ty -> Ordering) + -- ^ Function defining the ordering relationship + -> (Offset ty) -- ^ Offset to first element to sort + -> (CountOf ty) -- ^ Number of elements to sort + -> container -- ^ Data to be sorted + -> prim () +inplaceSortBy ford start len mvec + = qsort start (start `offsetPlusE` len `offsetSub` 1) + where + qsort lo hi + | lo >= hi = pure () + | otherwise = do + p <- partition lo hi + qsort lo (pred p) + qsort (p+1) hi + pivotStrategy (Offset low) hi@(Offset high) = do + let mid = Offset $ (low + high) `div` 2 + pivot <- read mvec mid + read mvec hi >>= write mvec mid + write mvec hi pivot -- move pivot @ pivotpos := hi + pure pivot + partition lo hi = do + pivot <- pivotStrategy lo hi + -- RETURN: index of pivot with [=pivot] + -- INVARIANT: i & j are valid array indices; pivotpos==hi + let go i j = do + -- INVARIANT: k <= pivotpos + let fw k = do ak <- read mvec k + if ford ak pivot == LT + then fw (k+1) + else pure (k, ak) + (i, ai) <- fw i -- POST: ai >= pivot + -- INVARIANT: k >= i + let bw k | k==i = pure (i, ai) + | otherwise = do ak <- read mvec k + if ford ak pivot /= LT + then bw (pred k) + else pure (k, ak) + (j, aj) <- bw j -- POST: i==j OR (aj=pivot AND (i==j OR aj=p AND aj= pivot + -- complete partitioning by swapping pivot to the center + write mvec hi ai + write mvec i pivot + pure i + go lo hi +{-# INLINE inplaceSortBy #-} diff --git a/bundled/Basement/Alg/PrimArray.hs b/bundled/Basement/Alg/PrimArray.hs new file mode 100644 index 0000000..657c292 --- /dev/null +++ b/bundled/Basement/Alg/PrimArray.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MagicHash #-} +module Basement.Alg.PrimArray + ( Indexable, index + , findIndexElem + , revFindIndexElem + , findIndexPredicate + , revFindIndexPredicate + , foldl + , foldr + , foldl1 + , all + , any + , filter + ) where + +import GHC.Types +import GHC.Prim +import Basement.Alg.Class +import Basement.Compat.Base +import Basement.Numerical.Additive +import Basement.Numerical.Multiplicative +import Basement.Types.OffsetSize +import Basement.PrimType +import Basement.Monad + +findIndexElem :: (Indexable container ty, Eq ty) => ty -> container -> Offset ty -> Offset ty -> Offset ty +findIndexElem ty ba startIndex endIndex = loop startIndex + where + loop !i + | i >= endIndex = sentinel + | index ba i == ty = i + | otherwise = loop (i+1) +{-# INLINE findIndexElem #-} + +revFindIndexElem :: (Indexable container ty, Eq ty) => ty -> container -> Offset ty -> Offset ty -> Offset ty +revFindIndexElem ty ba startIndex endIndex = loop endIndex + where + loop !iplus1 + | iplus1 <= startIndex = sentinel + | index ba i == ty = i + | otherwise = loop i + where !i = iplus1 `offsetMinusE` 1 +{-# INLINE revFindIndexElem #-} + +findIndexPredicate :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Offset ty +findIndexPredicate predicate ba startIndex endIndex = loop startIndex + where + loop !i + | i >= endIndex = sentinel + | predicate (index ba i) = i + | otherwise = loop (i+1) +{-# INLINE findIndexPredicate #-} + +revFindIndexPredicate :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Offset ty +revFindIndexPredicate predicate ba startIndex endIndex = loop endIndex + where + loop !iplus1 + | iplus1 <= startIndex = sentinel + | predicate (index ba i) = i + | otherwise = loop i + where !i = iplus1 `offsetMinusE` 1 +{-# INLINE revFindIndexPredicate #-} + +foldl :: Indexable container ty => (a -> ty -> a) -> a -> container -> Offset ty -> Offset ty -> a +foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc + where + loop !i !acc + | i == endIndex = acc + | otherwise = loop (i+1) (f acc (index ba i)) +{-# INLINE foldl #-} + +foldr :: Indexable container ty => (ty -> a -> a) -> a -> container -> Offset ty -> Offset ty -> a +foldr f !initialAcc ba startIndex endIndex = loop startIndex + where + loop !i + | i == endIndex = initialAcc + | otherwise = index ba i `f` loop (i+1) +{-# INLINE foldr #-} + +foldl1 :: Indexable container ty => (ty -> ty -> ty) -> container -> Offset ty -> Offset ty -> ty +foldl1 f ba startIndex endIndex = loop (startIndex+1) (index ba startIndex) + where + loop !i !acc + | i == endIndex = acc + | otherwise = loop (i+1) (f acc (index ba i)) +{-# INLINE foldl1 #-} + +filter :: (PrimMonad prim, PrimType ty, Indexable container ty) + => (ty -> Bool) -> MutableByteArray# (PrimState prim) + -> container -> Offset ty -> Offset ty -> prim (CountOf ty) +filter predicate dst src start end = loop azero start + where + loop !d !s + | s == end = pure (offsetAsSize d) + | predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1) + | otherwise = loop d (s+Offset 1) + where + v = index src s +{-# INLINE filter #-} + +all :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Bool +all predicate ba start end = loop start + where + loop !i + | i == end = True + | predicate (index ba i) = loop (i+1) + | otherwise = False +{-# INLINE all #-} + +any :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Bool +any predicate ba start end = loop start + where + loop !i + | i == end = False + | predicate (index ba i) = True + | otherwise = loop (i+1) +{-# INLINE any #-} diff --git a/bundled/Basement/Alg/String.hs b/bundled/Basement/Alg/String.hs new file mode 100644 index 0000000..db425b7 --- /dev/null +++ b/bundled/Basement/Alg/String.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +module Basement.Alg.String + ( copyFilter + , validate + , findIndexPredicate + , revFindIndexPredicate + ) where + +import GHC.Prim +import GHC.ST +import Basement.Alg.Class +import Basement.Alg.UTF8 +import Basement.Compat.Base +import Basement.Numerical.Additive +import Basement.Types.OffsetSize +import Basement.PrimType +import Basement.Block (MutableBlock(..)) + +import Basement.UTF8.Helper +import Basement.UTF8.Table +import Basement.UTF8.Types + +copyFilter :: forall s container . Indexable container Word8 + => (Char -> Bool) + -> CountOf Word8 + -> MutableByteArray# s + -> container + -> Offset Word8 + -> ST s (CountOf Word8) +copyFilter predicate !sz dst src start = loop (Offset 0) start + where + !end = start `offsetPlusE` sz + loop !d !s + | s == end = pure (offsetAsSize d) + | otherwise = + let !h = nextAscii src s + in case headerIsAscii h of + True | predicate (toChar1 h) -> primMbaWrite dst d (stepAsciiRawValue h) >> loop (d + Offset 1) (s + Offset 1) + | otherwise -> loop d (s + Offset 1) + False -> + case next src s of + Step c s' | predicate c -> writeUTF8 (MutableBlock dst :: MutableBlock Word8 s) d c >>= \d' -> loop d' s' + | otherwise -> loop d s' +{-# INLINE copyFilter #-} + +validate :: Indexable container Word8 + => Offset Word8 + -> container + -> Offset Word8 + -> (Offset Word8, Maybe ValidationFailure) +validate end ba ofsStart = loop4 ofsStart + where + loop4 !ofs + | ofs4 < end = + let h1 = nextAscii ba ofs + h2 = nextAscii ba (ofs+1) + h3 = nextAscii ba (ofs+2) + h4 = nextAscii ba (ofs+3) + in if headerIsAscii h1 && headerIsAscii h2 && headerIsAscii h3 && headerIsAscii h4 + then loop4 ofs4 + else loop ofs + | otherwise = loop ofs + where + !ofs4 = ofs+4 + loop !ofs + | ofs == end = (end, Nothing) + | headerIsAscii h = loop (ofs + Offset 1) + | otherwise = multi (CountOf $ getNbBytes h) ofs + where + h = nextAscii ba ofs + + multi (CountOf 0xff) pos = (pos, Just InvalidHeader) + multi nbConts pos + | (posNext `offsetPlusE` nbConts) > end = (pos, Just MissingByte) + | otherwise = + case nbConts of + CountOf 1 -> + let c1 = index ba posNext + in if isContinuation c1 + then loop (pos + Offset 2) + else (pos, Just InvalidContinuation) + CountOf 2 -> + let c1 = index ba posNext + c2 = index ba (pos + Offset 2) + in if isContinuation2 c1 c2 + then loop (pos + Offset 3) + else (pos, Just InvalidContinuation) + CountOf _ -> + let c1 = index ba posNext + c2 = index ba (pos + Offset 2) + c3 = index ba (pos + Offset 3) + in if isContinuation3 c1 c2 c3 + then loop (pos + Offset 4) + else (pos, Just InvalidContinuation) + where posNext = pos + Offset 1 +{-# INLINE validate #-} + +findIndexPredicate :: Indexable container Word8 + => (Char -> Bool) + -> container + -> Offset Word8 + -> Offset Word8 + -> Offset Word8 +findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex + where + loop !i + | i < endIndex && not (predicate c) = loop (i') + | otherwise = i + where + Step c i' = next ba i +{-# INLINE findIndexPredicate #-} + +revFindIndexPredicate :: Indexable container Word8 + => (Char -> Bool) + -> container + -> Offset Word8 + -> Offset Word8 + -> Offset Word8 +revFindIndexPredicate predicate ba startIndex endIndex + | endIndex > startIndex = loop endIndex + | otherwise = endIndex + where + loop !i + | predicate c = i' + | i' > startIndex = loop i' + | otherwise = endIndex + where + StepBack c i' = prev ba i +{-# INLINE revFindIndexPredicate #-} diff --git a/bundled/Basement/Alg/UTF8.hs b/bundled/Basement/Alg/UTF8.hs new file mode 100644 index 0000000..d003ed5 --- /dev/null +++ b/bundled/Basement/Alg/UTF8.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +module Basement.Alg.UTF8 + ( nextAscii + , nextAsciiDigit + , expectAscii + , next + , nextSkip + , nextWith + , prev + , prevSkip + , writeASCII + , writeUTF8 + , toList + , all + , any + , foldr + , length + , reverse + ) where + +import GHC.Types +import GHC.Word +import GHC.Prim +import Data.Bits +import Data.Proxy +import Basement.Alg.Class +import Basement.Compat.Base hiding (toList) +import Basement.Compat.Primitive +import Basement.Monad +import Basement.Numerical.Additive +import Basement.Numerical.Subtractive +import Basement.Types.OffsetSize +import Basement.Types.Char7 (Char7(..)) +import Basement.IntegralConv +import Basement.PrimType +import Basement.UTF8.Helper +import Basement.UTF8.Table +import Basement.UTF8.Types + +nextAscii :: Indexable container Word8 => container -> Offset Word8 -> StepASCII +nextAscii ba n = StepASCII w + where + !w = index ba n +{-# INLINE nextAscii #-} + +-- | nextAsciiBa specialized to get a digit between 0 and 9 (included) +nextAsciiDigit :: Indexable container Word8 => container -> Offset Word8 -> StepDigit +nextAsciiDigit ba n = StepDigit (index ba n - 0x30) +{-# INLINE nextAsciiDigit #-} + +expectAscii :: Indexable container Word8 => container -> Offset Word8 -> Word8 -> Bool +expectAscii ba n v = index ba n == v +{-# INLINE expectAscii #-} + +next :: Indexable container Word8 => container -> Offset8 -> Step +next ba n = + case getNbBytes h of + 0 -> Step (toChar1 h) (n + Offset 1) + 1 -> Step (toChar2 h (index ba (n + Offset 1))) (n + Offset 2) + 2 -> Step (toChar3 h (index ba (n + Offset 1)) + (index ba (n + Offset 2))) (n + Offset 3) + 3 -> Step (toChar4 h (index ba (n + Offset 1)) + (index ba (n + Offset 2)) + (index ba (n + Offset 3))) (n + Offset 4) + r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show (stepAsciiRawValue h)) + where + !h = nextAscii ba n +{-# INLINE next #-} + +nextSkip :: Indexable container Word8 => container -> Offset Word8 -> Offset Word8 +nextSkip ba n = n + 1 + Offset (getNbBytes (nextAscii ba n)) +{-# INLINE nextSkip #-} + +-- | special case for only non ascii next'er function +nextWith :: Indexable container Word8 + => StepASCII + -> container + -> Offset8 + -> Step +nextWith h ba n = + case getNbBytes h of + 1 -> Step (toChar2 h (index ba n)) (n + Offset 1) + 2 -> Step (toChar3 h (index ba n) (index ba (n + Offset 1))) (n + Offset 2) + 3 -> Step (toChar4 h (index ba n) + (index ba (n + Offset 1)) + (index ba (n + Offset 2))) (n + Offset 3) + r -> error ("nextWith: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show (stepAsciiRawValue h)) +{-# INLINE nextWith #-} + +-- Given a non null offset, give the previous character and the offset of this character +-- will fail bad if apply at the beginning of string or an empty string. +prev :: Indexable container Word8 => container -> Offset Word8 -> StepBack +prev ba offset = + case integralUpsize $ index ba prevOfs1 of + (W# v1) | isContinuationW# v1 -> atLeast2 (maskContinuation# v1) + | otherwise -> StepBack (toChar# v1) prevOfs1 + where + sz1 = CountOf 1 + !prevOfs1 = offset `offsetMinusE` sz1 + prevOfs2 = prevOfs1 `offsetMinusE` sz1 + prevOfs3 = prevOfs2 `offsetMinusE` sz1 + prevOfs4 = prevOfs3 `offsetMinusE` sz1 + atLeast2 !v = + case integralUpsize $ index ba prevOfs2 of + (W# v2) | isContinuationW# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v) + | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2 + atLeast3 !v = + case integralUpsize $ index ba prevOfs3 of + (W# v3) | isContinuationW# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v) + | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3 + atLeast4 !v = + case integralUpsize $ index ba prevOfs4 of + (W# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4 + +prevSkip :: Indexable container Word8 => container -> Offset Word8 -> Offset Word8 +prevSkip ba offset = loop (offset `offsetMinusE` sz1) + where + sz1 = CountOf 1 + loop o + | isContinuation (index ba o) = loop (o `offsetMinusE` sz1) + | otherwise = o + +writeASCII :: (PrimMonad prim, RandomAccess container prim Word8) + => container -> Offset8 -> Char7 -> prim () +writeASCII mba !i (Char7 c) = write mba i c +{-# INLINE writeASCII #-} + +writeUTF8 :: (PrimMonad prim, RandomAccess container prim Word8) + => container -> Offset8 -> Char -> prim Offset8 +writeUTF8 mba !i !c + | bool# (ltWord# x 0x80## ) = encode1 + | bool# (ltWord# x 0x800## ) = encode2 + | bool# (ltWord# x 0x10000##) = encode3 + | otherwise = encode4 + where + !(I# xi) = fromEnum c + !x = int2Word# xi + + encode1 = write mba i (W8# (wordToWord8# x)) >> pure (i + Offset 1) + encode2 = do + let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## + x2 = toContinuation x + write mba i (W8# (wordToWord8# x1)) + write mba (i+1) (W8# (wordToWord8# x2)) + pure (i + Offset 2) + + encode3 = do + let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## + x2 = toContinuation (uncheckedShiftRL# x 6#) + x3 = toContinuation x + write mba i (W8# (wordToWord8# x1)) + write mba (i+Offset 1) (W8# (wordToWord8# x2)) + write mba (i+Offset 2) (W8# (wordToWord8# x3)) + pure (i + Offset 3) + + encode4 = do + let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## + x2 = toContinuation (uncheckedShiftRL# x 12#) + x3 = toContinuation (uncheckedShiftRL# x 6#) + x4 = toContinuation x + write mba i (W8# (wordToWord8# x1)) + write mba (i+Offset 1) (W8# (wordToWord8# x2)) + write mba (i+Offset 2) (W8# (wordToWord8# x3)) + write mba (i+Offset 3) (W8# (wordToWord8# x4)) + pure (i + Offset 4) + + toContinuation :: Word# -> Word# + toContinuation w = or# (and# w 0x3f##) 0x80## +{-# INLINE writeUTF8 #-} + +toList :: Indexable container Word8 => container -> Offset Word8 -> Offset Word8 -> [Char] +toList ba !start !end = loop start + where + loop !idx + | idx == end = [] + | otherwise = c : loop idx' + where (Step c idx') = next ba idx + +all :: Indexable container Word8 + => (Char -> Bool) -> container -> Offset Word8 -> Offset Word8 -> Bool +all predicate ba start end = loop start + where + loop !idx + | idx == end = True + | predicate c = loop idx' + | otherwise = False + where (Step c idx') = next ba idx +{-# INLINE all #-} + +any :: Indexable container Word8 + => (Char -> Bool) -> container -> Offset Word8 -> Offset Word8 -> Bool +any predicate ba start end = loop start + where + loop !idx + | idx == end = False + | predicate c = True + | otherwise = loop idx' + where (Step c idx') = next ba idx +{-# INLINE any #-} + +foldr :: Indexable container Word8 + => container -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a +foldr dat start end f acc = loop start + where + loop !i + | i == end = acc + | otherwise = + let (Step c i') = next dat i + in c `f` loop i' +{-# INLINE foldr #-} + +length :: (Indexable container Word8, Indexable container Word64) + => container -> Offset Word8 -> Offset Word8 -> CountOf Char +length dat start end + | start == end = 0 + | otherwise = processStart 0 start + where + end64 :: Offset Word64 + end64 = offsetInElements end + + prx64 :: Proxy Word64 + prx64 = Proxy + + mask64_80 :: Word64 + mask64_80 = 0x8080808080808080 + + processStart :: CountOf Char -> Offset Word8 -> CountOf Char + processStart !c !i + | i == end = c + | offsetIsAligned prx64 i = processAligned c (offsetInElements i) + | otherwise = + let h = index dat i + cont = (h .&. 0xc0) == 0x80 + c' = if cont then c else c+1 + in processStart c' (i+1) + processAligned :: CountOf Char -> Offset Word64 -> CountOf Char + processAligned !c !i + | i >= end64 = processEnd c (offsetInBytes i) + | otherwise = + let !h = index dat i -- Word64 + !h80 = h .&. mask64_80 + in if h80 == 0 + then processAligned (c+8) (i+1) + else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80) + !nbHigh = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1)) + in processAligned (c + nbAscii + nbHigh) (i+1) + processEnd !c !i + | i == end = c + | otherwise = + let h = index dat i + cont = (h .&. 0xc0) == 0x80 + c' = if cont then c else c+1 + in processStart c' (i+1) +{-# INLINE length #-} + +reverse :: (PrimMonad prim, Indexable container Word8) + => MutableByteArray# (PrimState prim) -- ^ Destination buffer + -> Offset Word8 -- ^ Destination start + -> container -- ^ Source buffer + -> Offset Word8 -- ^ Source start + -> Offset Word8 -- ^ Source end + -> prim () +reverse dst dstOfs src start end + | start == end = pure () + | otherwise = loop (dstOfs `offsetPlusE` (offsetAsSize (end `offsetSub` start)) `offsetSub` 1) start + where + loop !d !s + | s == end = pure () + | headerIsAscii h = primMbaWrite dst d (stepAsciiRawValue h) >> loop (d `offsetSub` 1) (s + 1) + | otherwise = do + case getNbBytes h of + 1 -> do + primMbaWrite dst (d `offsetSub` 1) (stepAsciiRawValue h) + primMbaWrite dst d (index src (s + 1)) + loop (d `offsetSub` 2) (s + 2) + 2 -> do + primMbaWrite dst (d `offsetSub` 2) (stepAsciiRawValue h) + primMbaWrite dst (d `offsetSub` 1) (index src (s + 1)) + primMbaWrite dst d (index src (s + 2)) + loop (d `offsetSub` 3) (s + 3) + 3 -> do + primMbaWrite dst (d `offsetSub` 3) (stepAsciiRawValue h) + primMbaWrite dst (d `offsetSub` 2) (index src (s + 1)) + primMbaWrite dst (d `offsetSub` 1) (index src (s + 2)) + primMbaWrite dst d (index src (s + 3)) + loop (d `offsetSub` 4) (s + 4) + _ -> error "impossible" + where h = nextAscii src s +{-# INLINE reverse #-} diff --git a/bundled/Basement/Alg/XorShift.hs b/bundled/Basement/Alg/XorShift.hs new file mode 100644 index 0000000..9fca665 --- /dev/null +++ b/bundled/Basement/Alg/XorShift.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Foundation.Random.XorShift +-- License : BSD-style +-- +-- XorShift variant: Xoroshiro128+ +-- +-- +-- Xoroshiro128+ is a PRNG that uses a shift/rotate-based linear transformation. +-- This is lar +-- +-- C implementation at: +-- +-- +module Basement.Alg.XorShift + ( State(..) + , next + , nextDouble + , jump + ) where + +import Data.Word +import Data.Bits +import Basement.Compat.Base +import Basement.Floating (wordToDouble) +import Basement.Numerical.Additive +import Basement.Numerical.Subtractive + +-- | State of Xoroshiro128 plus +data State = State {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 + +-- | Given a state, call the function 'f' with the generated Word64 and the next State +next :: State -> (Word64 -> State -> a) -> a +next (State s0 s1prev) f = f ran stNext + where + !stNext = State s0' s1' + !ran = s0 + s1prev + !s1 = s0 `xor` s1prev + s0' = (s0 `rotateL` 55) `xor` s1 `xor` (s1 `unsafeShiftL` 14) + s1' = (s1 `rotateL` 36) + +-- | Same as 'next' but give a random value of type Double in the range of [0.0 .. 1.0] +nextDouble :: State -> (Double -> State -> a) -> a +nextDouble st f = next st $ \w -> f (toDouble w) + where + -- generate a number in the interval [1..2[ by bit manipulation. + -- this generate double with a ~2^52 + toDouble w = wordToDouble (upperMask .|. (w .&. lowerMask)) - 1.0 + where + upperMask = 0x3FF0000000000000 + lowerMask = 0x000FFFFFFFFFFFFF + +-- | Jump the state by 2^64 calls of next +jump :: State -> State +jump (State s0 s1) = withK 0xd86b048b86aa9922 + $ withK 0xbeac0467eba5facb + $ (State 0 0) + where + withK :: Word64 -> State -> State + withK !k = loop 0 + where + loop !i st@(State c0 c1) + | i == 64 = st + | testBit k i = loop (i+1) (State (c0 `xor` s0) (c1 `xor` s1)) + | otherwise = st diff --git a/bundled/Basement/Base16.hs b/bundled/Basement/Base16.hs new file mode 100644 index 0000000..96c989d --- /dev/null +++ b/bundled/Basement/Base16.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +module Basement.Base16 + ( unsafeConvertByte + , hexWord16 + , hexWord32 + , escapeByte + , Base16Escape(..) + ) where + +import GHC.Prim (Addr#, indexWord8OffAddr#, word2Int#, chr#) +import GHC.Types +import GHC.Word +import Basement.Types.Char7 +import Basement.Compat.Primitive + +data Base16Escape = Base16Escape {-# UNPACK #-} !Char7 {-# UNPACK #-} !Char7 + +-- | Convert a byte value in Word# to two Word#s containing +-- the hexadecimal representation of the Word# +-- +-- The output words# are guaranteed to be included in the 0 to 2^7-1 range +-- +-- Note that calling convertByte with a value greater than 256 +-- will cause segfault or other horrible effect. From GHC9.2, Word8# +-- cannot be >= 256. +unsafeConvertByte :: Word8# -> (# Word8#, Word8# #) +unsafeConvertByte b = (# r tableHi b, r tableLo b #) + where + r :: Table -> Word8# -> Word8# + r (Table !table) index = indexWord8OffAddr# table (word2Int# (word8ToWord# index)) +{-# INLINE unsafeConvertByte #-} + +escapeByte :: Word8 -> Base16Escape +escapeByte !(W8# b) = Base16Escape (r tableHi b) (r tableLo b) + where + r :: Table -> Word8# -> Char7 + r (Table !table) index = Char7 (W8# (indexWord8OffAddr# table (word2Int# (word8ToWord# index)))) +{-# INLINE escapeByte #-} + +-- | hex word16 +hexWord16 :: Word16 -> (Char, Char, Char, Char) +hexWord16 (W16# w) = (toChar w1,toChar w2,toChar w3,toChar w4) + where + toChar :: Word8# -> Char + toChar c = C# (chr# (word2Int# (word8ToWord# c))) + !(# w1, w2 #) = unsafeConvertByte (word16ToWord8# (uncheckedShiftRLWord16# w 8#)) + !(# w3, w4 #) = unsafeConvertByte (word16ToWord8# w) + +-- | hex word32 +hexWord32 :: Word32 -> (Char, Char, Char, Char, Char, Char, Char, Char) +hexWord32 (W32# w) = (toChar w1,toChar w2,toChar w3,toChar w4 + ,toChar w5,toChar w6,toChar w7,toChar w8) + where + toChar :: Word8# -> Char + toChar c = C# (chr# (word2Int# (word8ToWord# c))) + !(# w1, w2 #) = unsafeConvertByte (word32ToWord8# (uncheckedShiftRLWord32# w 24#)) + !(# w3, w4 #) = unsafeConvertByte (word32ToWord8# (uncheckedShiftRLWord32# w 16#)) + !(# w5, w6 #) = unsafeConvertByte (word32ToWord8# (uncheckedShiftRLWord32# w 8#)) + !(# w7, w8 #) = unsafeConvertByte (word32ToWord8# w) + +data Table = Table Addr# + +tableLo:: Table +tableLo = Table + "0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef"# + +tableHi :: Table +tableHi = Table + "00000000000000001111111111111111\ + \22222222222222223333333333333333\ + \44444444444444445555555555555555\ + \66666666666666667777777777777777\ + \88888888888888889999999999999999\ + \aaaaaaaaaaaaaaaabbbbbbbbbbbbbbbb\ + \ccccccccccccccccdddddddddddddddd\ + \eeeeeeeeeeeeeeeeffffffffffffffff"# diff --git a/bundled/Basement/Bindings/Memory.hs b/bundled/Basement/Bindings/Memory.hs new file mode 100644 index 0000000..5a1ec58 --- /dev/null +++ b/bundled/Basement/Bindings/Memory.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +module Basement.Bindings.Memory + where + +import GHC.IO +import GHC.Prim +import GHC.Word +import Basement.Compat.C.Types +import Foreign.Ptr +import Basement.Types.OffsetSize + +foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpBaBa :: + ByteArray# -> Offset Word8 -> ByteArray# -> Offset Word8 -> CountOf Word8 -> IO CInt + +foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpBaPtr :: + ByteArray# -> Offset Word8 -> Ptr a -> Offset Word8 -> CountOf Word8 -> IO CInt + +foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpPtrBa :: + Ptr a -> Offset Word8 -> ByteArray# -> Offset Word8 -> CountOf Word8 -> IO CInt + +foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpPtrPtr :: + Ptr a -> Offset Word8 -> Ptr b -> Offset Word8 -> CountOf Word8 -> IO CInt + +foreign import ccall unsafe "_foundation_mem_findbyte" sysHsMemFindByteBa :: + ByteArray# -> Offset Word8 -> Offset Word8 -> Word8 -> Offset Word8 + +foreign import ccall unsafe "_foundation_mem_findbyte" sysHsMemFindByteAddr :: + Addr# -> Offset Word8 -> Offset Word8 -> Word8 -> Offset Word8 diff --git a/bundled/Basement/Bits.hs b/bundled/Basement/Bits.hs new file mode 100644 index 0000000..3ff8821 --- /dev/null +++ b/bundled/Basement/Bits.hs @@ -0,0 +1,478 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Bits +-- License : BSD-style +-- Maintainer : Haskell Foundation +-- Stability : experimental +-- Portability : portable +-- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NegativeLiterals #-} + +#include "MachDeps.h" + +module Basement.Bits + ( BitOps(..) + , FiniteBitsOps(..) + , Bits + , toBits + , allOne + ) where + +import Basement.Compat.Base +import Basement.Compat.Natural +import Basement.Numerical.Additive +import Basement.Numerical.Subtractive +import Basement.Numerical.Multiplicative +import Basement.Types.OffsetSize +import Basement.Types.Word128 (Word128) +import qualified Basement.Types.Word128 as Word128 +import Basement.Types.Word256 (Word256) +import qualified Basement.Types.Word256 as Word256 +import Basement.IntegralConv (wordToInt) +import Basement.Nat + +import qualified Prelude +import qualified Data.Bits as OldBits +import Data.Maybe (fromMaybe) +import Data.Proxy +import GHC.Base hiding ((.)) +import GHC.Prim +import GHC.Types +import GHC.Word +import GHC.Int +import Basement.Compat.Primitive + +#if WORD_SIZE_IN_BITS < 64 +import GHC.IntWord64 +#endif + +-- | operation over finite bits +class FiniteBitsOps bits where + -- | get the number of bits in the given object + -- + numberOfBits :: bits -> CountOf Bool + + -- | rotate the given bit set. + rotateL :: bits -> CountOf Bool -> bits + -- | rotate the given bit set. + rotateR :: bits -> CountOf Bool -> bits + + -- | count of number of bit set to 1 in the given bit set. + popCount :: bits -> CountOf Bool + + -- | reverse all bits in the argument + bitFlip :: bits -> bits + + -- | count of the number of leading zeros + countLeadingZeros :: bits -> CountOf Bool + default countLeadingZeros :: BitOps bits => bits -> CountOf Bool + countLeadingZeros n = loop stop azero + where + stop = numberOfBits n + loop idx count + | idx == azero = count + | isBitSet n (sizeAsOffset idx) = count + | otherwise = loop (fromMaybe azero (idx - 1)) (count + 1) + + -- | count of the number of trailing zeros + countTrailingZeros :: bits -> CountOf Bool + default countTrailingZeros :: BitOps bits => bits -> CountOf Bool + countTrailingZeros n = loop azero + where + stop = numberOfBits n + loop count + | count == stop = count + | isBitSet n (sizeAsOffset count) = count + | otherwise = loop (count + 1) + +-- | operation over bits +class BitOps bits where + (.&.) :: bits -> bits -> bits + (.|.) :: bits -> bits -> bits + (.^.) :: bits -> bits -> bits + (.<<.) :: bits -> CountOf Bool -> bits + (.>>.) :: bits -> CountOf Bool -> bits + -- | construct a bit set with the bit at the given index set. + bit :: Offset Bool -> bits + default bit :: Integral bits => Offset Bool -> bits + bit n = 1 .<<. (offsetAsSize n) + + -- | test the bit at the given index is set + isBitSet :: bits -> Offset Bool -> Bool + default isBitSet :: (Integral bits, Eq bits) => bits -> Offset Bool -> Bool + isBitSet x n = x .&. (bit n) /= 0 + + -- | set the bit at the given index + setBit :: bits -> Offset Bool -> bits + default setBit :: Integral bits => bits -> Offset Bool -> bits + setBit x n = x .|. (bit n) + + -- | clear the bit at the given index + clearBit :: bits -> Offset Bool -> bits + default clearBit :: FiniteBitsOps bits => bits -> Offset Bool -> bits + clearBit x n = x .&. (bitFlip (bit n)) + +infixl 8 .<<., .>>., `rotateL`, `rotateR` +infixl 7 .&. +infixl 6 .^. +infixl 5 .|. + +-- | Bool set of 'n' bits. +-- +newtype Bits (n :: Nat) = Bits { bitsToNatural :: Natural } + deriving (Show, Eq, Ord, Typeable) + +-- | convenient Type Constraint Alias fot 'Bits' functions +type SizeValid n = (KnownNat n, 1 <= n) + +-- convert an 'Int' into a 'Natural'. +-- This functions is not meant to be exported +lift :: Int -> Natural +lift = Prelude.fromIntegral +{-# INLINABLE lift #-} + +-- | convert the given 'Natural' into a 'Bits' of size 'n' +-- +-- if bits that are not within the boundaries of the 'Bits n' will be truncated. +toBits :: SizeValid n => Natural -> Bits n +toBits nat = Bits nat .&. allOne + +-- | construct a 'Bits' with all bits set. +-- +-- this function is equivalet to 'maxBound' +allOne :: forall n . SizeValid n => Bits n +allOne = Bits (2 Prelude.^ n Prelude.- midentity) + where + n = natVal (Proxy @n) + +instance SizeValid n => Enum (Bits n) where + toEnum i | i < 0 && lift i > bitsToNatural maxi = error "Bits n not within bound" + | otherwise = Bits (lift i) + where maxi = allOne :: Bits n + fromEnum (Bits n) = fromEnum n +instance SizeValid n => Bounded (Bits n) where + minBound = azero + maxBound = allOne +instance SizeValid n => Additive (Bits n) where + azero = Bits 0 + (+) (Bits a) (Bits b) = toBits (a + b) + scale n (Bits a) = toBits (scale n a) +instance SizeValid n => Subtractive (Bits n) where + type Difference (Bits n) = Bits n + (-) (Bits a) (Bits b) = maybe azero toBits (a - b) +instance SizeValid n => Multiplicative (Bits n) where + midentity = Bits 1 + (*) (Bits a) (Bits b) = Bits (a Prelude.* b) +instance SizeValid n => IDivisible (Bits n) where + div (Bits a) (Bits b) = Bits (a `Prelude.div` b) + mod (Bits a) (Bits b) = Bits (a `Prelude.mod` b) + divMod (Bits a) (Bits b) = let (q, r) = Prelude.divMod a b in (Bits q, Bits r) + +instance SizeValid n => BitOps (Bits n) where + (.&.) (Bits a) (Bits b) = Bits (a OldBits..&. b) + (.|.) (Bits a) (Bits b) = Bits (a OldBits..|. b) + (.^.) (Bits a) (Bits b) = Bits (a `OldBits.xor` b) + (.<<.) (Bits a) (CountOf w) = Bits (a `OldBits.shiftL` w) + (.>>.) (Bits a) (CountOf w) = Bits (a `OldBits.shiftR` w) + bit (Offset w) = Bits (OldBits.bit w) + isBitSet (Bits a) (Offset w) = OldBits.testBit a w + setBit (Bits a) (Offset w) = Bits (OldBits.setBit a w) + clearBit (Bits a) (Offset w) = Bits (OldBits.clearBit a w) +instance (SizeValid n, NatWithinBound (CountOf Bool) n) => FiniteBitsOps (Bits n) where + bitFlip (Bits a) = Bits (OldBits.complement a) + numberOfBits _ = natValCountOf (Proxy @n) + rotateL a i = (a .<<. i) .|. (a .>>. d) + where + n = natValCountOf (Proxy :: Proxy n) + d = fromMaybe (fromMaybe (error "impossible") (i - n)) (n - i) + rotateR a i = (a .>>. i) .|. (a .<<. d) + where + n = natValCountOf (Proxy :: Proxy n) + d = fromMaybe (fromMaybe (error "impossible") (i - n)) (n - i) + popCount (Bits n) = CountOf (OldBits.popCount n) + +-- Bool ------------------------------------------------------------------------ + +instance FiniteBitsOps Bool where + numberOfBits _ = 1 + rotateL x _ = x + rotateR x _ = x + popCount True = 1 + popCount False = 0 + bitFlip = not + countLeadingZeros True = 0 + countLeadingZeros False = 1 + countTrailingZeros True = 0 + countTrailingZeros False = 1 +instance BitOps Bool where + (.&.) = (&&) + (.|.) = (||) + (.^.) = (/=) + x .<<. 0 = x + _ .<<. _ = False + x .>>. 0 = x + _ .>>. _ = False + bit 0 = True + bit _ = False + isBitSet x 0 = x + isBitSet _ _ = False + setBit _ 0 = True + setBit _ _ = False + clearBit _ 0 = False + clearBit x _ = x + +-- Word8 ---------------------------------------------------------------------- + +instance FiniteBitsOps Word8 where + numberOfBits _ = 8 + rotateL w (CountOf i) = w `OldBits.rotateL` i + rotateR w (CountOf i) = w `OldBits.rotateR` i + bitFlip = OldBits.complement + popCount (W8# x#) = CountOf $ wordToInt (W# (popCnt8# (word8ToWord# x#))) + countLeadingZeros (W8# w) = CountOf (wordToInt (W# (clz8# (word8ToWord# w)))) + countTrailingZeros (W8# w) = CountOf (wordToInt (W# (ctz8# (word8ToWord# w)))) +instance BitOps Word8 where + (.&.) a b = (a OldBits..&. b) + (.|.) a b = (a OldBits..|. b) + (.^.) a b = (a `OldBits.xor` b) + (.<<.) a (CountOf w) = (a `OldBits.shiftL` w) + (.>>.) a (CountOf w) = (a `OldBits.shiftR` w) + +-- Word16 --------------------------------------------------------------------- + +instance FiniteBitsOps Word16 where + numberOfBits _ = 16 + rotateL w (CountOf i) = w `OldBits.rotateL` i + rotateR w (CountOf i) = w `OldBits.rotateR` i + bitFlip = OldBits.complement + popCount (W16# x#) = CountOf $ wordToInt (W# (popCnt16# (word16ToWord# x#))) + countLeadingZeros (W16# w#) = CountOf $ wordToInt (W# (clz16# (word16ToWord# w#))) + countTrailingZeros (W16# w#) = CountOf $ wordToInt (W# (ctz16# (word16ToWord# w#))) +instance BitOps Word16 where + (.&.) a b = (a OldBits..&. b) + (.|.) a b = (a OldBits..|. b) + (.^.) a b = (a `OldBits.xor` b) + (.<<.) a (CountOf w) = (a `OldBits.shiftL` w) + (.>>.) a (CountOf w) = (a `OldBits.shiftR` w) + +-- Word32 --------------------------------------------------------------------- + +instance FiniteBitsOps Word32 where + numberOfBits _ = 32 + rotateL w (CountOf i) = w `OldBits.rotateL` i + rotateR w (CountOf i) = w `OldBits.rotateR` i + bitFlip = OldBits.complement + popCount (W32# x#) = CountOf $ wordToInt (W# (popCnt32# (word32ToWord# x#))) + countLeadingZeros (W32# w#) = CountOf $ wordToInt (W# (clz32# (word32ToWord# w#))) + countTrailingZeros (W32# w#) = CountOf $ wordToInt (W# (ctz32# (word32ToWord# w#))) +instance BitOps Word32 where + (.&.) a b = (a OldBits..&. b) + (.|.) a b = (a OldBits..|. b) + (.^.) a b = (a `OldBits.xor` b) + (.<<.) a (CountOf w) = (a `OldBits.shiftL` w) + (.>>.) a (CountOf w) = (a `OldBits.shiftR` w) + +-- Word --------------------------------------------------------------------- + +#if WORD_SIZE_IN_BITS == 64 +instance FiniteBitsOps Word where + numberOfBits _ = 64 + rotateL w (CountOf i) = w `OldBits.rotateL` i + rotateR w (CountOf i) = w `OldBits.rotateR` i + bitFlip = OldBits.complement +#if __GLASGOW_HASKELL__ >= 904 + popCount (W# x#) = CountOf $ wordToInt (W# (popCnt64# (wordToWord64# x#))) + countLeadingZeros (W# w#) = CountOf $ wordToInt (W# (clz64# (wordToWord64# w#))) + countTrailingZeros (W# w#) = CountOf $ wordToInt (W# (ctz64# (wordToWord64# w#))) +#else + popCount (W# x#) = CountOf $ wordToInt (W# (popCnt64# x#)) + countLeadingZeros (W# w#) = CountOf $ wordToInt (W# (clz64# w#)) + countTrailingZeros (W# w#) = CountOf $ wordToInt (W# (ctz64# w#)) +#endif +#else +instance FiniteBitsOps Word where + numberOfBits _ = 32 + rotateL w (CountOf i) = w `OldBits.rotateL` i + rotateR w (CountOf i) = w `OldBits.rotateR` i + bitFlip = OldBits.complement + popCount (W# x#) = CountOf $ wordToInt (W# (popCnt32# x#)) + countLeadingZeros (W# w#) = CountOf $ wordToInt (W# (clz32# w#)) + countTrailingZeros (W# w#) = CountOf $ wordToInt (W# (ctz32# w#)) +#endif + +instance BitOps Word where + (.&.) a b = (a OldBits..&. b) + (.|.) a b = (a OldBits..|. b) + (.^.) a b = (a `OldBits.xor` b) + (.<<.) a (CountOf w) = (a `OldBits.shiftL` w) + (.>>.) a (CountOf w) = (a `OldBits.shiftR` w) + +-- Word64 --------------------------------------------------------------------- + +#if WORD_SIZE_IN_BITS == 64 +instance FiniteBitsOps Word64 where + numberOfBits _ = 64 + rotateL w (CountOf i) = w `OldBits.rotateL` i + rotateR w (CountOf i) = w `OldBits.rotateR` i + bitFlip = OldBits.complement + popCount (W64# x#) = CountOf $ wordToInt (W# (popCnt64# x#)) + countLeadingZeros (W64# w#) = CountOf $ wordToInt (W# (clz64# w#)) + countTrailingZeros (W64# w#) = CountOf $ wordToInt (W# (ctz64# w#)) +instance BitOps Word64 where + (.&.) a b = (a OldBits..&. b) + (.|.) a b = (a OldBits..|. b) + (.^.) a b = (a `OldBits.xor` b) + (.<<.) a (CountOf w) = (a `OldBits.shiftL` w) + (.>>.) a (CountOf w) = (a `OldBits.shiftR` w) +#else +instance FiniteBitsOps Word64 where + numberOfBits _ = 64 + rotateL w (CountOf i) = w `OldBits.rotateL` i + rotateR w (CountOf i) = w `OldBits.rotateR` i + bitFlip = OldBits.complement + popCount (W64# x#) = CountOf $ wordToInt (W# (popCnt64# x#)) + countLeadingZeros (W64# w#) = CountOf $ wordToInt (W# (clz64# w#)) + countTrailingZeros (W64# w#) = CountOf $ wordToInt (W# (ctz64# w#)) +instance BitOps Word64 where + (.&.) a b = (a OldBits..&. b) + (.|.) a b = (a OldBits..|. b) + (.^.) a b = (a `OldBits.xor` b) + (.<<.) a (CountOf w) = (a `OldBits.shiftL` w) + (.>>.) a (CountOf w) = (a `OldBits.shiftR` w) +#endif + +-- Word128 -------------------------------------------------------------------- + +instance FiniteBitsOps Word128 where + numberOfBits _ = 128 + rotateL w (CountOf n) = Word128.rotateL w n + rotateR w (CountOf n) = Word128.rotateR w n + bitFlip = Word128.complement + popCount = CountOf . Word128.popCount +instance BitOps Word128 where + (.&.) = Word128.bitwiseAnd + (.|.) = Word128.bitwiseOr + (.^.) = Word128.bitwiseXor + (.<<.) w (CountOf n) = Word128.shiftL w n + (.>>.) w (CountOf n) = Word128.shiftR w n + +-- Word256 -------------------------------------------------------------------- + +instance FiniteBitsOps Word256 where + numberOfBits _ = 256 + rotateL w (CountOf n) = Word256.rotateL w n + rotateR w (CountOf n) = Word256.rotateR w n + bitFlip = Word256.complement + popCount = CountOf . Word256.popCount +instance BitOps Word256 where + (.&.) = Word256.bitwiseAnd + (.|.) = Word256.bitwiseOr + (.^.) = Word256.bitwiseXor + (.<<.) w (CountOf n) = Word256.shiftL w n + (.>>.) w (CountOf n) = Word256.shiftR w n + +-- Int8 ----------------------------------------------------------------------- +instance FiniteBitsOps Int8 where + numberOfBits _ = 8 + rotateL w (CountOf i) = w `OldBits.rotateL` i + rotateR w (CountOf i) = w `OldBits.rotateR` i + bitFlip = OldBits.complement + popCount (I8# x#) = CountOf $ wordToInt (W# (popCnt8# (int2Word# (int8ToInt# x#)))) + countLeadingZeros (I8# w#) = CountOf $ wordToInt (W# (clz8# (int2Word# (int8ToInt# w#)))) + countTrailingZeros (I8# w#) = CountOf $ wordToInt (W# (ctz8# (int2Word# (int8ToInt# w#)))) +instance BitOps Int8 where + (.&.) a b = (a OldBits..&. b) + (.|.) a b = (a OldBits..|. b) + (.^.) a b = (a `OldBits.xor` b) + (.<<.) a (CountOf w) = (a `OldBits.shiftL` w) + (.>>.) a (CountOf w) = (a `OldBits.shiftR` w) + +-- Int16 ---------------------------------------------------------------------- + +instance FiniteBitsOps Int16 where + numberOfBits _ = 16 + rotateL w (CountOf i) = w `OldBits.rotateL` i + rotateR w (CountOf i) = w `OldBits.rotateR` i + bitFlip = OldBits.complement + popCount (I16# x#) = CountOf $ wordToInt (W# (popCnt16# (int2Word# (int16ToInt# x#)))) + countLeadingZeros (I16# w#) = CountOf $ wordToInt (W# (clz16# (int2Word# (int16ToInt# w#)))) + countTrailingZeros (I16# w#) = CountOf $ wordToInt (W# (ctz16# (int2Word# (int16ToInt# w#)))) +instance BitOps Int16 where + (.&.) a b = (a OldBits..&. b) + (.|.) a b = (a OldBits..|. b) + (.^.) a b = (a `OldBits.xor` b) + (.<<.) a (CountOf w) = (a `OldBits.shiftL` w) + (.>>.) a (CountOf w) = (a `OldBits.shiftR` w) + +-- Int32 ---------------------------------------------------------------------- + +instance FiniteBitsOps Int32 where + numberOfBits _ = 32 + rotateL w (CountOf i) = w `OldBits.rotateL` i + rotateR w (CountOf i) = w `OldBits.rotateR` i + bitFlip = OldBits.complement + popCount (I32# x#) = CountOf $ wordToInt (W# (popCnt32# (int2Word# (int32ToInt# x#)))) + countLeadingZeros (I32# w#) = CountOf $ wordToInt (W# (clz32# (int2Word# (int32ToInt# w#)))) + countTrailingZeros (I32# w#) = CountOf $ wordToInt (W# (ctz32# (int2Word# (int32ToInt# w#)))) +instance BitOps Int32 where + (.&.) a b = (a OldBits..&. b) + (.|.) a b = (a OldBits..|. b) + (.^.) a b = (a `OldBits.xor` b) + (.<<.) a (CountOf w) = (a `OldBits.shiftL` w) + (.>>.) a (CountOf w) = (a `OldBits.shiftR` w) +-- Int64 ---------------------------------------------------------------------- + +#if WORD_SIZE_IN_BITS == 64 +instance FiniteBitsOps Int64 where + numberOfBits _ = 64 + rotateL w (CountOf i) = w `OldBits.rotateL` i + rotateR w (CountOf i) = w `OldBits.rotateR` i + bitFlip = OldBits.complement +#if __GLASGOW_HASKELL__ >= 904 + popCount (I64# x#) = CountOf $ wordToInt (W# (popCnt64# (wordToWord64# (int2Word# (int64ToInt# x#))))) + countLeadingZeros (I64# w#) = CountOf $ wordToInt (W# (clz64# (wordToWord64# (int2Word# (int64ToInt# w#))))) + countTrailingZeros (I64# w#) = CountOf $ wordToInt (W# (ctz64# (wordToWord64# (int2Word# (int64ToInt# w#))))) +#else + popCount (I64# x#) = CountOf $ wordToInt (W# (popCnt64# (int2Word# x#))) + countLeadingZeros (I64# w#) = CountOf $ wordToInt (W# (clz64# (int2Word# w#))) + countTrailingZeros (I64# w#) = CountOf $ wordToInt (W# (ctz64# (int2Word# w#))) +#endif +instance BitOps Int64 where + (.&.) a b = (a OldBits..&. b) + (.|.) a b = (a OldBits..|. b) + (.^.) a b = (a `OldBits.xor` b) + (.<<.) a (CountOf w) = (a `OldBits.shiftL` w) + (.>>.) a (CountOf w) = (a `OldBits.shiftR` w) +#else +instance FiniteBitsOps Int64 where + numberOfBits _ = 64 + rotateL w (CountOf i) = w `OldBits.rotateL` i + rotateR w (CountOf i) = w `OldBits.rotateR` i + bitFlip = OldBits.complement + popCount (I64# x#) = CountOf $ wordToInt (W# (popCnt64# (int64ToWord64# x#))) + countLeadingZeros (I64# w#) = CountOf $ wordToInt (W# (clz64# (int64ToWord64# w#))) + countTrailingZeros (I64# w#) = CountOf $ wordToInt (W# (ctz64# (int64ToWord64# w#))) +instance BitOps Int64 where + (.&.) a b = (a OldBits..&. b) + (.|.) a b = (a OldBits..|. b) + (.^.) a b = (a `OldBits.xor` b) + (.<<.) a (CountOf w) = (a `OldBits.shiftL` w) + (.>>.) a (CountOf w) = (a `OldBits.shiftR` w) + +#endif diff --git a/bundled/Basement/Block.hs b/bundled/Basement/Block.hs new file mode 100644 index 0000000..74b2265 --- /dev/null +++ b/bundled/Basement/Block.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Block +-- License : BSD-style +-- Maintainer : Haskell Foundation +-- +-- A block of memory that contains elements of a type, +-- very similar to an unboxed array but with the key difference: +-- +-- * It doesn't have slicing capability (no cheap take or drop) +-- * It consume less memory: 1 Offset, 1 CountOf +-- * It's unpackable in any constructor +-- * It uses unpinned memory by default +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +module Basement.Block + ( Block(..) + , MutableBlock(..) + -- * Properties + , length + -- * Lowlevel functions + , unsafeThaw + , unsafeFreeze + , unsafeIndex + , thaw + , freeze + , copy + , unsafeCast + , cast + -- * safer api + , empty + , create + , isPinned + , isMutablePinned + , singleton + , replicate + , index + , map + , foldl' + , foldr + , foldl1' + , foldr1 + , cons + , snoc + , uncons + , unsnoc + , sub + , splitAt + , revSplitAt + , splitOn + , break + , breakEnd + , span + , elem + , all + , any + , find + , filter + , reverse + , sortBy + , intersperse + -- * Foreign interfaces + , createFromPtr + , unsafeCopyToPtr + , withPtr + ) where + +import GHC.Prim +import GHC.Types +import GHC.ST +import qualified Data.List +import Basement.Compat.Base +import Data.Proxy +import Basement.Compat.Primitive +import Basement.NonEmpty +import Basement.Types.OffsetSize +import Basement.Monad +import Basement.Exception +import Basement.PrimType +import qualified Basement.Block.Mutable as M +import Basement.Block.Mutable (Block(..), MutableBlock(..), new, unsafeThaw, unsafeFreeze) +import Basement.Block.Base +import Basement.Numerical.Additive +import Basement.Numerical.Subtractive +import Basement.Numerical.Multiplicative +import qualified Basement.Alg.Mutable as MutAlg +import qualified Basement.Alg.Class as Alg +import qualified Basement.Alg.PrimArray as Alg + +instance (PrimMonad prim, st ~ PrimState prim, PrimType ty) + => Alg.RandomAccess (MutableBlock ty st) prim ty where + read (MutableBlock mba) = primMbaRead mba + write (MutableBlock mba) = primMbaWrite mba + +instance (PrimType ty) => Alg.Indexable (Block ty) ty where + index (Block ba) = primBaIndex ba + {-# INLINE index #-} + +instance Alg.Indexable (Block Word8) Word64 where + index (Block ba) = primBaIndex ba + {-# INLINE index #-} + +-- | Copy all the block content to the memory starting at the destination address +unsafeCopyToPtr :: forall ty prim . PrimMonad prim + => Block ty -- ^ the source block to copy + -> Ptr ty -- ^ The destination address where the copy is going to start + -> prim () +unsafeCopyToPtr (Block blk) (Ptr p) = primitive $ \s1 -> + (# copyByteArrayToAddr# blk 0# p (sizeofByteArray# blk) s1, () #) + +-- | Create a new array of size @n by settings each cells through the +-- function @f. +create :: forall ty . PrimType ty + => CountOf ty -- ^ the size of the block (in element of ty) + -> (Offset ty -> ty) -- ^ the function that set the value at the index + -> Block ty -- ^ the array created +create n initializer + | n == 0 = mempty + | otherwise = runST $ do + mb <- new n + M.iterSet initializer mb + unsafeFreeze mb + +-- | Freeze a chunk of memory pointed, of specific size into a new unboxed array +createFromPtr :: PrimType ty + => Ptr ty + -> CountOf ty + -> IO (Block ty) +createFromPtr p sz = do + mb <- new sz + M.copyFromPtr p mb 0 sz + unsafeFreeze mb + +singleton :: PrimType ty => ty -> Block ty +singleton ty = create 1 (const ty) + +replicate :: PrimType ty => CountOf ty -> ty -> Block ty +replicate sz ty = create sz (const ty) + +-- | Thaw a Block into a MutableBlock +-- +-- the Block is not modified, instead a new Mutable Block is created +-- and its content is copied to the mutable block +thaw :: (PrimMonad prim, PrimType ty) => Block ty -> prim (MutableBlock ty (PrimState prim)) +thaw array = do + ma <- M.unsafeNew Unpinned (lengthBytes array) + M.unsafeCopyBytesRO ma 0 array 0 (lengthBytes array) + pure ma +{-# INLINE thaw #-} + +-- | Freeze a MutableBlock into a Block, copying all the data +-- +-- If the data is modified in the mutable block after this call, then +-- the immutable Block resulting is not impacted. +freeze :: (PrimType ty, PrimMonad prim) => MutableBlock ty (PrimState prim) -> prim (Block ty) +freeze ma = do + ma' <- unsafeNew Unpinned len + M.unsafeCopyBytes ma' 0 ma 0 len + --M.copyAt ma' (Offset 0) ma (Offset 0) len + unsafeFreeze ma' + where + len = M.mutableLengthBytes ma + +-- | Copy every cells of an existing Block to a new Block +copy :: PrimType ty => Block ty -> Block ty +copy array = runST (thaw array >>= unsafeFreeze) + +-- | Return the element at a specific index from an array. +-- +-- If the index @n is out of bounds, an error is raised. +index :: PrimType ty => Block ty -> Offset ty -> ty +index array n + | isOutOfBound n len = outOfBound OOB_Index n len + | otherwise = unsafeIndex array n + where + !len = length array +{-# INLINE index #-} + +-- | Map all element 'a' from a block to a new block of 'b' +map :: (PrimType a, PrimType b) => (a -> b) -> Block a -> Block b +map f a = create lenB (\i -> f $ unsafeIndex a (offsetCast Proxy i)) + where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (length a) + +foldr :: PrimType ty => (ty -> a -> a) -> a -> Block ty -> a +foldr f initialAcc vec = loop 0 + where + !len = length vec + loop !i + | i .==# len = initialAcc + | otherwise = unsafeIndex vec i `f` loop (i+1) +{-# SPECIALIZE [2] foldr :: (Word8 -> a -> a) -> a -> Block Word8 -> a #-} + +foldl' :: PrimType ty => (a -> ty -> a) -> a -> Block ty -> a +foldl' f initialAcc vec = loop 0 initialAcc + where + !len = length vec + loop !i !acc + | i .==# len = acc + | otherwise = loop (i+1) (f acc (unsafeIndex vec i)) +{-# SPECIALIZE [2] foldl' :: (a -> Word8 -> a) -> a -> Block Word8 -> a #-} + +foldl1' :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (Block ty) -> ty +foldl1' f (NonEmpty arr) = loop 1 (unsafeIndex arr 0) + where + !len = length arr + loop !i !acc + | i .==# len = acc + | otherwise = loop (i+1) (f acc (unsafeIndex arr i)) +{-# SPECIALIZE [3] foldl1' :: (Word8 -> Word8 -> Word8) -> NonEmpty (Block Word8) -> Word8 #-} + +foldr1 :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (Block ty) -> ty +foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr + in foldr f (unsafeIndex initialAcc 0) rest + +cons :: PrimType ty => ty -> Block ty -> Block ty +cons e vec + | len == 0 = singleton e + | otherwise = runST $ do + muv <- new (len + 1) + M.unsafeCopyElementsRO muv 1 vec 0 len + M.unsafeWrite muv 0 e + unsafeFreeze muv + where + !len = length vec + +snoc :: PrimType ty => Block ty -> ty -> Block ty +snoc vec e + | len == 0 = singleton e + | otherwise = runST $ do + muv <- new (len + 1) + M.unsafeCopyElementsRO muv 0 vec 0 len + M.unsafeWrite muv (0 `offsetPlusE` len) e + unsafeFreeze muv + where + !len = length vec + +sub :: PrimType ty => Block ty -> Offset ty -> Offset ty -> Block ty +sub blk start end + | start >= end' = mempty + | otherwise = runST $ do + dst <- new newLen + M.unsafeCopyElementsRO dst 0 blk start newLen + unsafeFreeze dst + where + newLen = end' - start + end' = min (sizeAsOffset len) end + !len = length blk + +uncons :: PrimType ty => Block ty -> Maybe (ty, Block ty) +uncons vec + | nbElems == 0 = Nothing + | otherwise = Just (unsafeIndex vec 0, sub vec 1 (0 `offsetPlusE` nbElems)) + where + !nbElems = length vec + +unsnoc :: PrimType ty => Block ty -> Maybe (Block ty, ty) +unsnoc vec = case length vec - 1 of + Nothing -> Nothing + Just offset -> Just (sub vec 0 lastElem, unsafeIndex vec lastElem) + where !lastElem = 0 `offsetPlusE` offset + +splitAt :: PrimType ty => CountOf ty -> Block ty -> (Block ty, Block ty) +splitAt nbElems blk + | nbElems <= 0 = (mempty, blk) + | Just nbTails <- length blk - nbElems, nbTails > 0 = runST $ do + left <- new nbElems + right <- new nbTails + M.unsafeCopyElementsRO left 0 blk 0 nbElems + M.unsafeCopyElementsRO right 0 blk (sizeAsOffset nbElems) nbTails + (,) <$> unsafeFreeze left <*> unsafeFreeze right + | otherwise = (blk, mempty) +{-# SPECIALIZE [2] splitAt :: CountOf Word8 -> Block Word8 -> (Block Word8, Block Word8) #-} + +revSplitAt :: PrimType ty => CountOf ty -> Block ty -> (Block ty, Block ty) +revSplitAt n blk + | n <= 0 = (mempty, blk) + | Just nbElems <- length blk - n = let (x, y) = splitAt nbElems blk in (y, x) + | otherwise = (blk, mempty) + +break :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty) +break predicate blk = findBreak 0 + where + !len = length blk + findBreak !i + | i .==# len = (blk, mempty) + | predicate (unsafeIndex blk i) = splitAt (offsetAsSize i) blk + | otherwise = findBreak (i + 1) + {-# INLINE findBreak #-} +{-# SPECIALIZE [2] break :: (Word8 -> Bool) -> Block Word8 -> (Block Word8, Block Word8) #-} + +breakEnd :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty) +breakEnd predicate blk + | k == sentinel = (blk, mempty) + | otherwise = splitAt (offsetAsSize (k+1)) blk + where + !k = Alg.revFindIndexPredicate predicate blk 0 end + !end = sizeAsOffset $ length blk +{-# SPECIALIZE [2] breakEnd :: (Word8 -> Bool) -> Block Word8 -> (Block Word8, Block Word8) #-} + +span :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty) +span p = break (not . p) + +elem :: PrimType ty => ty -> Block ty -> Bool +elem v blk = loop 0 + where + !len = length blk + loop !i + | i .==# len = False + | unsafeIndex blk i == v = True + | otherwise = loop (i+1) +{-# SPECIALIZE [2] elem :: Word8 -> Block Word8 -> Bool #-} + +all :: PrimType ty => (ty -> Bool) -> Block ty -> Bool +all p blk = loop 0 + where + !len = length blk + loop !i + | i .==# len = True + | p (unsafeIndex blk i) = loop (i+1) + | otherwise = False +{-# SPECIALIZE [2] all :: (Word8 -> Bool) -> Block Word8 -> Bool #-} + +any :: PrimType ty => (ty -> Bool) -> Block ty -> Bool +any p blk = loop 0 + where + !len = length blk + loop !i + | i .==# len = False + | p (unsafeIndex blk i) = True + | otherwise = loop (i+1) +{-# SPECIALIZE [2] any :: (Word8 -> Bool) -> Block Word8 -> Bool #-} + +splitOn :: PrimType ty => (ty -> Bool) -> Block ty -> [Block ty] +splitOn predicate blk + | len == 0 = [mempty] + | otherwise = go 0 0 + where + !len = length blk + go !prevIdx !idx + | idx .==# len = [sub blk prevIdx idx] + | otherwise = + let e = unsafeIndex blk idx + idx' = idx + 1 + in if predicate e + then sub blk prevIdx idx : go idx' idx' + else go prevIdx idx' + +find :: PrimType ty => (ty -> Bool) -> Block ty -> Maybe ty +find predicate vec = loop 0 + where + !len = length vec + loop i + | i .==# len = Nothing + | otherwise = + let e = unsafeIndex vec i + in if predicate e then Just e else loop (i+1) + +filter :: PrimType ty => (ty -> Bool) -> Block ty -> Block ty +filter predicate vec = fromList $ Data.List.filter predicate $ toList vec + +reverse :: forall ty . PrimType ty => Block ty -> Block ty +reverse blk + | len == 0 = mempty + | otherwise = runST $ do + mb <- new len + go mb + unsafeFreeze mb + where + !len = length blk + !endOfs = 0 `offsetPlusE` len + + go :: MutableBlock ty s -> ST s () + go mb = loop endOfs 0 + where + loop o i + | i .==# len = pure () + | otherwise = unsafeWrite mb o' (unsafeIndex blk i) >> loop o' (i+1) + where o' = pred o + +sortBy :: PrimType ty => (ty -> ty -> Ordering) -> Block ty -> Block ty +sortBy ford vec + | len == 0 = mempty + | otherwise = runST $ do + mblock <- thaw vec + MutAlg.inplaceSortBy ford 0 len mblock + unsafeFreeze mblock + where len = length vec +{-# SPECIALIZE [2] sortBy :: (Word8 -> Word8 -> Ordering) -> Block Word8 -> Block Word8 #-} + +intersperse :: forall ty . PrimType ty => ty -> Block ty -> Block ty +intersperse sep blk = case len - 1 of + Nothing -> blk + Just 0 -> blk + Just size -> runST $ do + mb <- new (len+size) + go mb + unsafeFreeze mb + where + !len = length blk + + go :: MutableBlock ty s -> ST s () + go mb = loop 0 0 + where + loop !o !i + | (i + 1) .==# len = unsafeWrite mb o (unsafeIndex blk i) + | otherwise = do + unsafeWrite mb o (unsafeIndex blk i) + unsafeWrite mb (o+1) sep + loop (o+2) (i+1) + +-- | Unsafely recast an UArray containing 'a' to an UArray containing 'b' +-- +-- The offset and size are converted from units of 'a' to units of 'b', +-- but no check are performed to make sure this is compatible. +-- +-- use 'cast' if unsure. +unsafeCast :: PrimType b => Block a -> Block b +unsafeCast (Block ba) = Block ba + +-- | Cast a Block of 'a' to a Block of 'b' +-- +-- The requirement is that the size of type 'a' need to be a multiple or +-- dividend of the size of type 'b'. +-- +-- If this requirement is not met, the InvalidRecast exception is thrown +cast :: forall a b . (PrimType a, PrimType b) => Block a -> Block b +cast blk@(Block ba) + | aTypeSize == bTypeSize || bTypeSize == 1 = unsafeCast blk + | missing == 0 = unsafeCast blk + | otherwise = + throw $ InvalidRecast (RecastSourceSize alen) (RecastDestinationSize $ alen + missing) + where + (CountOf alen) = lengthBytes blk + + aTypeSize = primSizeInBytes (Proxy :: Proxy a) + bTypeSize@(CountOf bs) = primSizeInBytes (Proxy :: Proxy b) + + missing = alen `mod` bs diff --git a/bundled/Basement/Block/Base.hs b/bundled/Basement/Block/Base.hs new file mode 100644 index 0000000..6bc17da --- /dev/null +++ b/bundled/Basement/Block/Base.hs @@ -0,0 +1,493 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} +module Basement.Block.Base + ( Block(..) + , MutableBlock(..) + -- * Basic accessor + , unsafeNew + , unsafeThaw + , unsafeFreeze + , unsafeShrink + , unsafeCopyElements + , unsafeCopyElementsRO + , unsafeCopyBytes + , unsafeCopyBytesRO + , unsafeCopyBytesPtr + , unsafeRead + , unsafeWrite + , unsafeIndex + -- * Properties + , length + , lengthBytes + , isPinned + , isMutablePinned + , mutableLength + , mutableLengthBytes + -- * Other methods + , empty + , mutableEmpty + , new + , newPinned + , withPtr + , withMutablePtr + , withMutablePtrHint + , mutableWithPtr + , unsafeRecast + ) where + +import GHC.Prim +import GHC.Types +import GHC.ST +import GHC.IO +import qualified Data.List +import Basement.Compat.Base +import Data.Proxy +import Basement.Compat.Primitive +import Basement.Compat.Semigroup +import Basement.Bindings.Memory (sysHsMemcmpBaBa) +import Basement.Types.OffsetSize +import Basement.Monad +import Basement.NormalForm +import Basement.Numerical.Additive +import Basement.PrimType + +-- | A block of memory containing unpacked bytes representing values of type 'ty' +data Block ty = Block ByteArray# + deriving (Typeable) + +unsafeBlockPtr :: Block ty -> Ptr ty +unsafeBlockPtr (Block arrBa) = Ptr (byteArrayContents# arrBa) +{-# INLINE unsafeBlockPtr #-} + +instance Data ty => Data (Block ty) where + dataTypeOf _ = blockType + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + +blockType :: DataType +blockType = mkNoRepType "Basement.Block" + +instance NormalForm (Block ty) where + toNormalForm (Block !_) = () +instance (PrimType ty, Show ty) => Show (Block ty) where + show v = show (toList v) +instance (PrimType ty, Eq ty) => Eq (Block ty) where + {-# SPECIALIZE instance Eq (Block Word8) #-} + (==) = equal +instance (PrimType ty, Ord ty) => Ord (Block ty) where + compare = internalCompare + +instance PrimType ty => Semigroup (Block ty) where + (<>) = append +instance PrimType ty => Monoid (Block ty) where + mempty = empty + mconcat = concat + +instance PrimType ty => IsList (Block ty) where + type Item (Block ty) = ty + fromList = internalFromList + toList = internalToList + +-- | A Mutable block of memory containing unpacked bytes representing values of type 'ty' +data MutableBlock ty st = MutableBlock (MutableByteArray# st) + +isPinned :: Block ty -> PinnedStatus +isPinned (Block ba) = toPinnedStatus# (compatIsByteArrayPinned# ba) + +isMutablePinned :: MutableBlock s ty -> PinnedStatus +isMutablePinned (MutableBlock mba) = toPinnedStatus# (compatIsMutableByteArrayPinned# mba) + +length :: forall ty . PrimType ty => Block ty -> CountOf ty +length (Block ba) = + case primShiftToBytes (Proxy :: Proxy ty) of + 0 -> CountOf (I# (sizeofByteArray# ba)) + (I# szBits) -> CountOf (I# (uncheckedIShiftRL# (sizeofByteArray# ba) szBits)) +{-# INLINE[1] length #-} +{-# SPECIALIZE [2] length :: Block Word8 -> CountOf Word8 #-} + +lengthBytes :: Block ty -> CountOf Word8 +lengthBytes (Block ba) = CountOf (I# (sizeofByteArray# ba)) +{-# INLINE[1] lengthBytes #-} + +-- | Return the length of a Mutable Block +-- +-- note: we don't allow resizing yet, so this can remain a pure function +mutableLength :: forall ty st . PrimType ty => MutableBlock ty st -> CountOf ty +mutableLength mb = sizeRecast $ mutableLengthBytes mb +{-# INLINE[1] mutableLength #-} + +mutableLengthBytes :: MutableBlock ty st -> CountOf Word8 +mutableLengthBytes (MutableBlock mba) = CountOf (I# (sizeofMutableByteArray# mba)) +{-# INLINE[1] mutableLengthBytes #-} + +-- | Create an empty block of memory +empty :: Block ty +empty = Block ba where !(Block ba) = empty_ + +empty_ :: Block () +empty_ = runST $ primitive $ \s1 -> + case newByteArray# 0# s1 of { (# s2, mba #) -> + case unsafeFreezeByteArray# mba s2 of { (# s3, ba #) -> + (# s3, Block ba #) }} + +mutableEmpty :: PrimMonad prim => prim (MutableBlock ty (PrimState prim)) +mutableEmpty = primitive $ \s1 -> + case newByteArray# 0# s1 of { (# s2, mba #) -> + (# s2, MutableBlock mba #) } + +-- | Return the element at a specific index from an array without bounds checking. +-- +-- Reading from invalid memory can return unpredictable and invalid values. +-- use 'index' if unsure. +unsafeIndex :: forall ty . PrimType ty => Block ty -> Offset ty -> ty +unsafeIndex (Block ba) n = primBaIndex ba n +{-# SPECIALIZE unsafeIndex :: Block Word8 -> Offset Word8 -> Word8 #-} +{-# INLINE unsafeIndex #-} + +-- | make a block from a list of elements. +internalFromList :: PrimType ty => [ty] -> Block ty +internalFromList l = runST $ do + ma <- new (CountOf len) + iter azero l $ \i x -> unsafeWrite ma i x + unsafeFreeze ma + where + !len = Data.List.length l + + iter _ [] _ = return () + iter !i (x:xs) z = z i x >> iter (i+1) xs z + +-- | transform a block to a list. +internalToList :: forall ty . PrimType ty => Block ty -> [ty] +internalToList blk@(Block ba) + | len == azero = [] + | otherwise = loop azero + where + !len = length blk + loop !i | i .==# len = [] + | otherwise = primBaIndex ba i : loop (i+1) + +-- | Check if two blocks are identical +equal :: (PrimType ty, Eq ty) => Block ty -> Block ty -> Bool +equal a b + | la /= lb = False + | otherwise = loop azero + where + !la = lengthBytes a + !lb = lengthBytes b + lat = length a + + loop !n | n .==# lat = True + | otherwise = (unsafeIndex a n == unsafeIndex b n) && loop (n+o1) + o1 = Offset (I# 1#) +{-# RULES "Block/Eq/Word8" [3] + forall (a :: Block Word8) b . equal a b = equalMemcmp a b #-} +{-# INLINEABLE [2] equal #-} +-- {-# SPECIALIZE equal :: Block Word8 -> Block Word8 -> Bool #-} + +equalMemcmp :: PrimMemoryComparable ty => Block ty -> Block ty -> Bool +equalMemcmp b1@(Block a) b2@(Block b) + | la /= lb = False + | otherwise = unsafeDupablePerformIO (sysHsMemcmpBaBa a 0 b 0 la) == 0 + where + la = lengthBytes b1 + lb = lengthBytes b2 +{-# SPECIALIZE equalMemcmp :: Block Word8 -> Block Word8 -> Bool #-} + +-- | Compare 2 blocks +internalCompare :: (Ord ty, PrimType ty) => Block ty -> Block ty -> Ordering +internalCompare a b = loop azero + where + !la = length a + !lb = length b + !end = sizeAsOffset (min la lb) + loop !n + | n == end = la `compare` lb + | v1 == v2 = loop (n + Offset (I# 1#)) + | otherwise = v1 `compare` v2 + where + v1 = unsafeIndex a n + v2 = unsafeIndex b n +{-# RULES "Block/Ord/Word8" [3] forall (a :: Block Word8) b . internalCompare a b = compareMemcmp a b #-} +{-# NOINLINE internalCompare #-} + +compareMemcmp :: PrimMemoryComparable ty => Block ty -> Block ty -> Ordering +compareMemcmp b1@(Block a) b2@(Block b) = + case unsafeDupablePerformIO (sysHsMemcmpBaBa a 0 b 0 sz) of + 0 -> la `compare` lb + n | n > 0 -> GT + | otherwise -> LT + where + la = lengthBytes b1 + lb = lengthBytes b2 + sz = min la lb +{-# SPECIALIZE [3] compareMemcmp :: Block Word8 -> Block Word8 -> Ordering #-} + +-- | Append 2 blocks together by creating a new bigger block +append :: Block ty -> Block ty -> Block ty +append a b + | la == azero = b + | lb == azero = a + | otherwise = runST $ do + r <- unsafeNew Unpinned (la+lb) + unsafeCopyBytesRO r 0 a 0 la + unsafeCopyBytesRO r (sizeAsOffset la) b 0 lb + unsafeFreeze r + where + !la = lengthBytes a + !lb = lengthBytes b + +concat :: forall ty . [Block ty] -> Block ty +concat original = runST $ do + r <- unsafeNew Unpinned total + goCopy r zero original + unsafeFreeze r + where + !total = size 0 original + -- size + size !sz [] = sz + size !sz (x:xs) = size (lengthBytes x + sz) xs + + zero = Offset 0 + + goCopy r = loop + where + loop _ [] = pure () + loop !i (x:xs) = do + unsafeCopyBytesRO r i x zero lx + loop (i `offsetPlusE` lx) xs + where !lx = lengthBytes x + +-- | Freeze a mutable block into a block. +-- +-- If the mutable block is still use after freeze, +-- then the modification will be reflected in an unexpected +-- way in the Block. +unsafeFreeze :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim (Block ty) +unsafeFreeze (MutableBlock mba) = primitive $ \s1 -> + case unsafeFreezeByteArray# mba s1 of + (# s2, ba #) -> (# s2, Block ba #) +{-# INLINE unsafeFreeze #-} + +unsafeShrink :: PrimMonad prim => MutableBlock ty (PrimState prim) -> CountOf ty -> prim (MutableBlock ty (PrimState prim)) +unsafeShrink (MutableBlock mba) (CountOf (I# nsz)) = primitive $ \s -> + case shrinkMutableByteArray# mba nsz s of + s -> (# s, MutableBlock mba #) + +-- | Thaw an immutable block. +-- +-- If the immutable block is modified, then the original immutable block will +-- be modified too, but lead to unexpected results when querying +unsafeThaw :: (PrimType ty, PrimMonad prim) => Block ty -> prim (MutableBlock ty (PrimState prim)) +unsafeThaw (Block ba) = primitive $ \st -> (# st, MutableBlock (unsafeCoerce# ba) #) + +-- | Create a new mutable block of a specific size in bytes. +-- +-- Note that no checks are made to see if the size in bytes is compatible with the size +-- of the underlaying element 'ty' in the block. +-- +-- use 'new' if unsure +unsafeNew :: PrimMonad prim + => PinnedStatus + -> CountOf Word8 + -> prim (MutableBlock ty (PrimState prim)) +unsafeNew pinSt (CountOf (I# bytes)) = case pinSt of + Unpinned -> primitive $ \s1 -> case newByteArray# bytes s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) } + _ -> primitive $ \s1 -> case newAlignedPinnedByteArray# bytes 8# s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) } + +-- | Create a new unpinned mutable block of a specific N size of 'ty' elements +-- +-- If the size exceeds a GHC-defined threshold, then the memory will be +-- pinned. To be certain about pinning status with small size, use 'newPinned' +new :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MutableBlock ty (PrimState prim)) +new n = unsafeNew Unpinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n) + +-- | Create a new pinned mutable block of a specific N size of 'ty' elements +newPinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MutableBlock ty (PrimState prim)) +newPinned n = unsafeNew Pinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n) + +-- | Copy a number of elements from an array to another array with offsets +unsafeCopyElements :: forall prim ty . (PrimMonad prim, PrimType ty) + => MutableBlock ty (PrimState prim) -- ^ destination mutable block + -> Offset ty -- ^ offset at destination + -> MutableBlock ty (PrimState prim) -- ^ source mutable block + -> Offset ty -- ^ offset at source + -> CountOf ty -- ^ number of elements to copy + -> prim () +unsafeCopyElements dstMb destOffset srcMb srcOffset n = -- (MutableBlock dstMba) ed (MutableBlock srcBa) es n = + unsafeCopyBytes dstMb (offsetOfE sz destOffset) + srcMb (offsetOfE sz srcOffset) + (sizeOfE sz n) + where + !sz = primSizeInBytes (Proxy :: Proxy ty) + +unsafeCopyElementsRO :: forall prim ty . (PrimMonad prim, PrimType ty) + => MutableBlock ty (PrimState prim) -- ^ destination mutable block + -> Offset ty -- ^ offset at destination + -> Block ty -- ^ source block + -> Offset ty -- ^ offset at source + -> CountOf ty -- ^ number of elements to copy + -> prim () +unsafeCopyElementsRO dstMb destOffset srcMb srcOffset n = + unsafeCopyBytesRO dstMb (offsetOfE sz destOffset) + srcMb (offsetOfE sz srcOffset) + (sizeOfE sz n) + where + !sz = primSizeInBytes (Proxy :: Proxy ty) + +-- | Copy a number of bytes from a MutableBlock to another MutableBlock with specific byte offsets +unsafeCopyBytes :: forall prim ty . PrimMonad prim + => MutableBlock ty (PrimState prim) -- ^ destination mutable block + -> Offset Word8 -- ^ offset at destination + -> MutableBlock ty (PrimState prim) -- ^ source mutable block + -> Offset Word8 -- ^ offset at source + -> CountOf Word8 -- ^ number of elements to copy + -> prim () +unsafeCopyBytes (MutableBlock dstMba) (Offset (I# d)) (MutableBlock srcBa) (Offset (I# s)) (CountOf (I# n)) = + primitive $ \st -> (# copyMutableByteArray# srcBa s dstMba d n st, () #) +{-# INLINE unsafeCopyBytes #-} + +-- | Copy a number of bytes from a Block to a MutableBlock with specific byte offsets +unsafeCopyBytesRO :: forall prim ty . PrimMonad prim + => MutableBlock ty (PrimState prim) -- ^ destination mutable block + -> Offset Word8 -- ^ offset at destination + -> Block ty -- ^ source block + -> Offset Word8 -- ^ offset at source + -> CountOf Word8 -- ^ number of elements to copy + -> prim () +unsafeCopyBytesRO (MutableBlock dstMba) (Offset (I# d)) (Block srcBa) (Offset (I# s)) (CountOf (I# n)) = + primitive $ \st -> (# copyByteArray# srcBa s dstMba d n st, () #) +{-# INLINE unsafeCopyBytesRO #-} + +-- | Copy a number of bytes from a Ptr to a MutableBlock with specific byte offsets +unsafeCopyBytesPtr :: forall prim ty . PrimMonad prim + => MutableBlock ty (PrimState prim) -- ^ destination mutable block + -> Offset Word8 -- ^ offset at destination + -> Ptr ty -- ^ source block + -> CountOf Word8 -- ^ number of bytes to copy + -> prim () +unsafeCopyBytesPtr (MutableBlock dstMba) (Offset (I# d)) (Ptr srcBa) (CountOf (I# n)) = + primitive $ \st -> (# copyAddrToByteArray# srcBa dstMba d n st, () #) +{-# INLINE unsafeCopyBytesPtr #-} + +-- | read from a cell in a mutable block without bounds checking. +-- +-- Reading from invalid memory can return unpredictable and invalid values. +-- use 'read' if unsure. +unsafeRead :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> prim ty +unsafeRead (MutableBlock mba) i = primMbaRead mba i +{-# INLINE unsafeRead #-} + +-- | write to a cell in a mutable block without bounds checking. +-- +-- Writing with invalid bounds will corrupt memory and your program will +-- become unreliable. use 'write' if unsure. +unsafeWrite :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim () +unsafeWrite (MutableBlock mba) i v = primMbaWrite mba i v +{-# INLINE unsafeWrite #-} + +-- | Get a Ptr pointing to the data in the Block. +-- +-- Since a Block is immutable, this Ptr shouldn't be +-- to use to modify the contents +-- +-- If the Block is pinned, then its address is returned as is, +-- however if it's unpinned, a pinned copy of the Block is made +-- before getting the address. +withPtr :: PrimMonad prim + => Block ty + -> (Ptr ty -> prim a) + -> prim a +withPtr x@(Block ba) f + | isPinned x == Pinned = f (Ptr (byteArrayContents# ba)) <* touch x + | otherwise = do + arr <- makeTrampoline + f (unsafeBlockPtr arr) <* touch arr + where + makeTrampoline = do + trampoline <- unsafeNew Pinned (lengthBytes x) + unsafeCopyBytesRO trampoline 0 x 0 (lengthBytes x) + unsafeFreeze trampoline + +touch :: PrimMonad prim => Block ty -> prim () +touch (Block ba) = + unsafePrimFromIO $ primitive $ \s -> case touch# ba s of { s2 -> (# s2, () #) } + +unsafeRecast :: (PrimType t1, PrimType t2) + => MutableBlock t1 st + -> MutableBlock t2 st +unsafeRecast (MutableBlock mba) = MutableBlock mba + +-- | Use the 'Ptr' to a mutable block in a safer construct +-- +-- If the block is not pinned, this is a _dangerous_ operation +mutableWithPtr :: PrimMonad prim + => MutableBlock ty (PrimState prim) + -> (Ptr ty -> prim a) + -> prim a +mutableWithPtr = withMutablePtr +{-# DEPRECATED mutableWithPtr "use withMutablePtr" #-} + +-- | Create a pointer on the beginning of the MutableBlock +-- and call a function 'f'. +-- +-- The mutable block can be mutated by the 'f' function +-- and the change will be reflected in the mutable block +-- +-- If the mutable block is unpinned, a trampoline buffer +-- is created and the data is only copied when 'f' return. +-- +-- it is all-in-all highly inefficient as this cause 2 copies +withMutablePtr :: PrimMonad prim + => MutableBlock ty (PrimState prim) + -> (Ptr ty -> prim a) + -> prim a +withMutablePtr = withMutablePtrHint False False + + +-- | Same as 'withMutablePtr' but allow to specify 2 optimisations +-- which is only useful when the MutableBlock is unpinned and need +-- a pinned trampoline to be called safely. +-- +-- If skipCopy is True, then the first copy which happen before +-- the call to 'f', is skipped. The Ptr is now effectively +-- pointing to uninitialized data in a new mutable Block. +-- +-- If skipCopyBack is True, then the second copy which happen after +-- the call to 'f', is skipped. Then effectively in the case of a +-- trampoline being used the memory changed by 'f' will not +-- be reflected in the original Mutable Block. +-- +-- If using the wrong parameters, it will lead to difficult to +-- debug issue of corrupted buffer which only present themselves +-- with certain Mutable Block that happened to have been allocated +-- unpinned. +-- +-- If unsure use 'withMutablePtr', which default to *not* skip +-- any copy. +withMutablePtrHint :: forall ty prim a . PrimMonad prim + => Bool -- ^ hint that the buffer doesn't need to have the same value as the mutable block when calling f + -> Bool -- ^ hint that the buffer is not supposed to be modified by call of f + -> MutableBlock ty (PrimState prim) + -> (Ptr ty -> prim a) + -> prim a +withMutablePtrHint skipCopy skipCopyBack mb f + | isMutablePinned mb == Pinned = callWithPtr mb + | otherwise = do + trampoline <- unsafeNew Pinned vecSz + unless skipCopy $ + unsafeCopyBytes trampoline 0 mb 0 vecSz + r <- callWithPtr trampoline + unless skipCopyBack $ + unsafeCopyBytes mb 0 trampoline 0 vecSz + pure r + where + vecSz = mutableLengthBytes mb + callWithPtr pinnedMb = do + b <- unsafeFreeze pinnedMb + f (unsafeBlockPtr b) <* touch b diff --git a/bundled/Basement/Block/Builder.hs b/bundled/Basement/Block/Builder.hs new file mode 100644 index 0000000..1ae1f20 --- /dev/null +++ b/bundled/Basement/Block/Builder.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Block.Builder +-- License : BSD-style +-- Maintainer : Foundation +-- +-- Block builder + +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeOperators #-} + +module Basement.Block.Builder + ( Builder + , run + + -- * Emit functions + , emit + , emitPrim + , emitString + , emitUTF8Char + + -- * unsafe + , unsafeRunString + ) where + +import qualified Basement.Alg.UTF8 as UTF8 +import Basement.UTF8.Helper (charToBytes) +import Basement.Numerical.Conversion (charToInt) +import Basement.Block.Base (Block(..), MutableBlock(..)) +import qualified Basement.Block.Base as B +import Basement.Cast +import Basement.Compat.Base +import Basement.Compat.Semigroup +import Basement.Monad +import Basement.FinalPtr (FinalPtr, withFinalPtr) +import Basement.Numerical.Additive +import Basement.String (String(..)) +import qualified Basement.String as S +import Basement.Types.OffsetSize +import Basement.PrimType (PrimType(..), primMbaWrite) +import Basement.UArray.Base (UArray(..)) +import qualified Basement.UArray.Base as A + +import GHC.ST +import Data.Proxy + +newtype Action = Action + { runAction_ :: forall prim . PrimMonad prim + => MutableBlock Word8 (PrimState prim) + -> Offset Word8 + -> prim (Offset Word8) + } + +data Builder = Builder {-# UNPACK #-} !(CountOf Word8) + !Action + +instance Semigroup Builder where + (<>) = append + {-# INLINABLE (<>) #-} +instance Monoid Builder where + mempty = empty + {-# INLINABLE mempty #-} + mconcat = concat + {-# INLINABLE mconcat #-} + +-- | create an empty builder +-- +-- this does nothing, build nothing, take no space (in the resulted block) +empty :: Builder +empty = Builder 0 (Action $ \_ !off -> pure off) +{-# INLINE empty #-} + +-- | concatenate the 2 given bulider +append :: Builder -> Builder -> Builder +append (Builder size1 (Action action1)) (Builder size2 (Action action2)) = + Builder size action + where + action = Action $ \arr off -> do + off' <- action1 arr off + action2 arr off' + size = size1 + size2 +{-# INLINABLE append #-} + +-- | concatenate the list of builder +concat :: [Builder] -> Builder +concat = loop 0 (Action $ \_ !off -> pure off) + where + loop !sz acc [] = Builder sz acc + loop !sz (Action acc) (Builder !s (Action action):xs) = + loop (sz + s) (Action $ \arr off -> acc arr off >>= action arr) xs +{-# INLINABLE concat #-} + +-- | run the given builder and return the generated block +run :: PrimMonad prim => Builder -> prim (Block Word8) +run (Builder sz action) = do + mb <- B.new sz + off <- runAction_ action mb 0 + B.unsafeShrink mb (offsetAsSize off) >>= B.unsafeFreeze + +-- | run the given builder and return a UTF8String +-- +-- this action is unsafe as there is no guarantee upon the validity of the +-- content of the built block. +unsafeRunString :: PrimMonad prim => Builder -> prim String +unsafeRunString b = do + str <- run b + pure $ String $ A.UArray 0 (B.length str) (A.UArrayBA str) + +-- | add a Block in the builder +emit :: Block a -> Builder +emit b = Builder size $ Action $ \arr off -> + B.unsafeCopyBytesRO arr off b' 0 size *> pure (off + sizeAsOffset size) + where + b' :: Block Word8 + b' = cast b + size :: CountOf Word8 + size = B.length b' + +emitPrim :: (PrimType ty, ty ~ Word8) => ty -> Builder +emitPrim a = Builder size $ Action $ \(MutableBlock arr) off -> + primMbaWrite arr off a *> pure (off + sizeAsOffset size) + where + size = getSize Proxy a + getSize :: PrimType ty => Proxy ty -> ty -> CountOf Word8 + getSize p _ = primSizeInBytes p + +-- | add a string in the builder +emitString :: String -> Builder +emitString (String str) = Builder size $ Action $ \arr off -> + A.onBackendPrim (onBA arr off) (onAddr arr off) str *> pure (off + sizeAsOffset size) + where + size = A.length str + onBA :: PrimMonad prim + => MutableBlock Word8 (PrimState prim) + -> Offset Word8 + -> Block Word8 + -> prim () + onBA arr off ba = B.unsafeCopyBytesRO arr off ba 0 size + onAddr :: PrimMonad prim + => MutableBlock Word8 (PrimState prim) + -> Offset Word8 + -> FinalPtr Word8 + -> prim () + onAddr arr off fptr = withFinalPtr fptr $ \ptr -> B.unsafeCopyBytesPtr arr off ptr size + +-- | emit a UTF8 char in the builder +-- +-- this function may be replaced by `emit :: Encoding -> Char -> Builder` +emitUTF8Char :: Char -> Builder +emitUTF8Char c = Builder (charToBytes $ charToInt c) $ Action $ \block@(MutableBlock !_) off -> + UTF8.writeUTF8 block off c diff --git a/bundled/Basement/Block/Mutable.hs b/bundled/Basement/Block/Mutable.hs new file mode 100644 index 0000000..ff433b9 --- /dev/null +++ b/bundled/Basement/Block/Mutable.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Block.Mutable +-- License : BSD-style +-- Maintainer : Haskell Foundation +-- +-- A block of memory that contains elements of a type, +-- very similar to an unboxed array but with the key difference: +-- +-- * It doesn't have slicing capability (no cheap take or drop) +-- * It consume less memory: 1 Offset, 1 CountOf, 1 Pinning status trimmed +-- * It's unpackable in any constructor +-- * It uses unpinned memory by default +-- +-- It should be rarely needed in high level API, but +-- in lowlevel API or some data structure containing lots +-- of unboxed array that will benefit from optimisation. +-- +-- Because it's unpinned, the blocks are compactable / movable, +-- at the expense of making them less friendly to interop with the C layer +-- as address. +-- +-- Note that sadly the bytearray primitive type automatically create +-- a pinned bytearray if the size is bigger than a certain threshold +-- +-- GHC Documentation associated: +-- +-- includes/rts/storage/Block.h +-- * LARGE_OBJECT_THRESHOLD ((uint32_t)(BLOCK_SIZE * 8 / 10)) +-- * BLOCK_SIZE (1< (Offset ty -> ty) + -> MutableBlock ty (PrimState prim) + -> prim () +iterSet f ma = loop 0 + where + !sz = mutableLength ma + loop i + | i .==# sz = pure () + | otherwise = unsafeWrite ma i (f i) >> loop (i+1) + {-# INLINE loop #-} + +mutableLengthSize :: PrimType ty => MutableBlock ty st -> CountOf ty +mutableLengthSize = mutableLength +{-# DEPRECATED mutableLengthSize "use mutableLength" #-} + +-- | read a cell in a mutable array. +-- +-- If the index is out of bounds, an error is raised. +read :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> prim ty +read array n + | isOutOfBound n len = primOutOfBound OOB_Read n len + | otherwise = unsafeRead array n + where len = mutableLength array +{-# INLINE read #-} + +-- | Write to a cell in a mutable array. +-- +-- If the index is out of bounds, an error is raised. +write :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim () +write array n val + | isOutOfBound n len = primOutOfBound OOB_Write n len + | otherwise = unsafeWrite array n val + where + len = mutableLengthSize array +{-# INLINE write #-} + +-- | Copy from a pointer, @count@ elements, into the Mutable Block at a starting offset @ofs@ +-- +-- if the source pointer is invalid (size or bad allocation), bad things will happen +-- +copyFromPtr :: forall prim ty . (PrimMonad prim, PrimType ty) + => Ptr ty -- ^ Source Ptr of 'ty' to start of memory + -> MutableBlock ty (PrimState prim) -- ^ Destination mutable block + -> Offset ty -- ^ Start offset in the destination mutable block + -> CountOf ty -- ^ Number of 'ty' elements + -> prim () +copyFromPtr src@(Ptr src#) mb@(MutableBlock mba) ofs count + | end > sizeAsOffset arrSz = primOutOfBound OOB_MemCopy end arrSz + | otherwise = primitive $ \st -> (# copyAddrToByteArray# src# mba od# bytes# st, () #) + where + end = od `offsetPlusE` arrSz + + sz = primSizeInBytes (Proxy :: Proxy ty) + !arrSz@(CountOf (I# bytes#)) = sizeOfE sz count + !od@(Offset (I# od#)) = offsetOfE sz ofs + +-- | Copy all the block content to the memory starting at the destination address +-- +-- If the destination pointer is invalid (size or bad allocation), bad things will happen +copyToPtr :: forall ty prim . (PrimType ty, PrimMonad prim) + => MutableBlock ty (PrimState prim) -- ^ The source mutable block to copy + -> Offset ty -- ^ The source offset in the mutable block + -> Ptr ty -- ^ The destination address where the copy is going to start + -> CountOf ty -- ^ The number of bytes + -> prim () +copyToPtr mb@(MutableBlock mba) ofs dst@(Ptr dst#) count + | srcEnd > sizeAsOffset arrSz = primOutOfBound OOB_MemCopy srcEnd arrSz + | otherwise = do + blk <- unsafeFreeze mb + let !(Block ba) = blk + primitive $ \s1 -> (# copyByteArrayToAddr# ba os# dst# szBytes# s1, () #) + where + srcEnd = os `offsetPlusE` arrSz + !os@(Offset (I# os#)) = offsetInBytes ofs + !arrSz@(CountOf (I# szBytes#)) = mutableLengthBytes mb diff --git a/bundled/Basement/BlockN.hs b/bundled/Basement/BlockN.hs new file mode 100644 index 0000000..b43fe9d --- /dev/null +++ b/bundled/Basement/BlockN.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Block +-- License : BSD-style +-- Maintainer : Haskell Foundation +-- +-- A Nat-sized version of Block + +module Basement.BlockN (module X) where + +import Basement.Sized.Block as X diff --git a/bundled/Basement/Bounded.hs b/bundled/Basement/Bounded.hs new file mode 100644 index 0000000..733b90a --- /dev/null +++ b/bundled/Basement/Bounded.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Block +-- License : BSD-style +-- Maintainer : Haskell Foundation +-- +-- Types to represent ℤ/nℤ. +-- +-- ℤ/nℤ is a finite field and is defined as the set of natural number: +-- {0, 1, ..., n − 1}. +-- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +module Basement.Bounded + ( Zn64 + , unZn64 + , Zn + , unZn + , zn64 + , zn + , zn64Nat + , znNat + ) where + +import GHC.TypeLits +import Data.Word +import Basement.Compat.Base +import Basement.Compat.Natural +import Basement.Numerical.Number +import Data.Proxy +import Basement.Nat +import qualified Prelude + +-- | A type level bounded natural backed by a Word64 +newtype Zn64 (n :: Nat) = Zn64 { unZn64 :: Word64 } + deriving (Show,Eq,Ord) + +instance (KnownNat n, NatWithinBound Word64 n) => Prelude.Num (Zn64 n) where + fromInteger = zn64 . Prelude.fromInteger + (+) = add64 + (-) = sub64 + (*) = mul64 + abs a = a + negate _ = error "cannot negate Zn64: use Foundation Numerical hierarchy for this function to not be exposed to Zn64" + signum (Zn64 a) = Zn64 (Prelude.signum a) + +type instance NatNumMaxBound (Zn64 n) = n + +instance (KnownNat n, NatWithinBound Word64 n) => Integral (Zn64 n) where + fromInteger = zn64 . Prelude.fromInteger +instance (KnownNat n, NatWithinBound Word64 n) => IsIntegral (Zn64 n) where + toInteger (Zn64 n) = toInteger n +instance (KnownNat n, NatWithinBound Word64 n) => IsNatural (Zn64 (n :: Nat)) where + toNatural (Zn64 n) = toNatural n + +-- | Create an element of ℤ/nℤ from a Word64 +-- +-- If the value is greater than n, then the value is normalized by using the +-- integer modulus n +zn64 :: forall n . (KnownNat n, NatWithinBound Word64 n) => Word64 -> Zn64 n +zn64 v = Zn64 (v `Prelude.mod` natValWord64 (Proxy :: Proxy n)) + +-- | Create an element of ℤ/nℤ from a type level Nat +zn64Nat :: forall m n . (KnownNat m, KnownNat n, NatWithinBound Word64 m, NatWithinBound Word64 n, CmpNat m n ~ 'LT) + => Proxy m + -> Zn64 n +zn64Nat p = Zn64 (natValWord64 p) + +-- | Add 2 Zn64 +add64 :: forall n . (KnownNat n, NatWithinBound Word64 n) => Zn64 n -> Zn64 n -> Zn64 n +add64 (Zn64 a) (Zn64 b) = Zn64 ((a Prelude.+ b) `Prelude.mod` natValWord64 (Proxy :: Proxy n)) + +-- | subtract 2 Zn64 +sub64 :: forall n . (KnownNat n, NatWithinBound Word64 n) => Zn64 n -> Zn64 n -> Zn64 n +sub64 (Zn64 a) (Zn64 b) = Zn64 ((a Prelude.- b) `Prelude.mod` natValWord64 (Proxy :: Proxy n)) + +-- | Multiply 2 Zn64 +mul64 :: forall n . (KnownNat n, NatWithinBound Word64 n) => Zn64 n -> Zn64 n -> Zn64 n +mul64 (Zn64 a) (Zn64 b) = Zn64 ((a Prelude.* b) `Prelude.mod` natValWord64 (Proxy :: Proxy n)) + +-- | A type level bounded natural +newtype Zn (n :: Nat) = Zn { unZn :: Natural } + deriving (Show,Eq,Ord) + +instance KnownNat n => Prelude.Num (Zn n) where + fromInteger = zn . Prelude.fromInteger + (+) = add + (-) = sub + (*) = mul + abs a = a + negate _ = error "cannot negate Zn: use Foundation Numerical hierarchy for this function to not be exposed to Zn" + signum = Zn . Prelude.signum . unZn + +type instance NatNumMaxBound (Zn n) = n + +instance KnownNat n => Integral (Zn n) where + fromInteger = zn . Prelude.fromInteger +instance KnownNat n => IsIntegral (Zn n) where + toInteger (Zn n) = toInteger n +instance KnownNat n => IsNatural (Zn n) where + toNatural i = unZn i + +-- | Create an element of ℤ/nℤ from a Natural. +-- +-- If the value is greater than n, then the value is normalized by using the +-- integer modulus n +zn :: forall n . KnownNat n => Natural -> Zn n +zn v = Zn (v `Prelude.mod` natValNatural (Proxy :: Proxy n)) + +-- | Create an element of ℤ/nℤ from a type level Nat +znNat :: forall m n . (KnownNat m, KnownNat n, CmpNat m n ~ 'LT) => Proxy m -> Zn n +znNat m = Zn (natValNatural m) + +-- | Add 2 Zn +add :: forall n . KnownNat n => Zn n -> Zn n -> Zn n +add (Zn a) (Zn b) = Zn ((a Prelude.+ b) `Prelude.mod` natValNatural (Proxy :: Proxy n)) + +-- | subtract 2 Zn +sub :: forall n . KnownNat n => Zn n -> Zn n -> Zn n +sub (Zn a) (Zn b) = Zn ((a Prelude.- b) `Prelude.mod` natValNatural (Proxy :: Proxy n)) + +-- | Multiply 2 Zn +mul :: forall n . KnownNat n => Zn n -> Zn n -> Zn n +mul (Zn a) (Zn b) = Zn ((a Prelude.* b) `Prelude.mod` natValNatural (Proxy :: Proxy n)) + diff --git a/bundled/Basement/BoxedArray.hs b/bundled/Basement/BoxedArray.hs new file mode 100644 index 0000000..83d0331 --- /dev/null +++ b/bundled/Basement/BoxedArray.hs @@ -0,0 +1,781 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.BoxedArray +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- Simple boxed array abstraction +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +module Basement.BoxedArray + ( Array + , MArray + , empty + , length + , mutableLength + , copy + , unsafeCopyAtRO + , thaw + , new + , create + , unsafeFreeze + , unsafeThaw + , freeze + , unsafeWrite + , unsafeRead + , unsafeIndex + , write + , read + , index + , singleton + , replicate + , null + , take + , drop + , splitAt + , revTake + , revDrop + , revSplitAt + , splitOn + , sub + , intersperse + , span + , spanEnd + , break + , breakEnd + , mapFromUnboxed + , mapToUnboxed + , cons + , snoc + , uncons + , unsnoc + -- , findIndex + , sortBy + , filter + , reverse + , elem + , find + , foldl' + , foldr + , foldl1' + , foldr1 + , all + , any + , isPrefixOf + , isSuffixOf + , builderAppend + , builderBuild + , builderBuild_ + ) where + +import GHC.Prim +import GHC.Types +import GHC.ST +import Data.Proxy +import Basement.Numerical.Additive +import Basement.Numerical.Subtractive +import Basement.NonEmpty +import Basement.Compat.Base +import qualified Basement.Alg.Class as Alg +import qualified Basement.Alg.Mutable as Alg +import Basement.Compat.MonadTrans +import Basement.Compat.Semigroup +import Basement.Compat.Primitive +import Basement.Types.OffsetSize +import Basement.PrimType +import Basement.NormalForm +import Basement.Monad +import Basement.UArray.Base (UArray) +import qualified Basement.UArray.Base as UArray +import Basement.Exception +import Basement.MutableBuilder +import qualified Basement.Compat.ExtList as List + +-- | Array of a +data Array a = Array {-# UNPACK #-} !(Offset a) + {-# UNPACK #-} !(CountOf a) + (Array# a) + deriving (Typeable) + +instance Data ty => Data (Array ty) where + dataTypeOf _ = arrayType + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + +arrayType :: DataType +arrayType = mkNoRepType "Foundation.Array" + +instance NormalForm a => NormalForm (Array a) where + toNormalForm arr = loop 0 + where + !sz = length arr + loop !i + | i .==# sz = () + | otherwise = unsafeIndex arr i `seq` loop (i+1) + +-- | Mutable Array of a +data MArray a st = MArray {-# UNPACK #-} !(Offset a) + {-# UNPACK #-} !(CountOf a) + (MutableArray# st a) + deriving (Typeable) + +instance Functor Array where + fmap = map + +instance Semigroup (Array a) where + (<>) = append +instance Monoid (Array a) where + mempty = empty + mconcat = concat + +instance Show a => Show (Array a) where + show v = show (toList v) + +instance Eq a => Eq (Array a) where + (==) = equal +instance Ord a => Ord (Array a) where + compare = vCompare + +instance IsList (Array ty) where + type Item (Array ty) = ty + fromList = vFromList + fromListN len = vFromListN (CountOf len) + toList = vToList + +-- | return the numbers of elements in a mutable array +mutableLength :: MArray ty st -> Int +mutableLength (MArray _ (CountOf len) _) = len +{-# INLINE mutableLength #-} + +-- | return the numbers of elements in a mutable array +mutableLengthSize :: MArray ty st -> CountOf ty +mutableLengthSize (MArray _ size _) = size +{-# INLINE mutableLengthSize #-} + +-- | Return the element at a specific index from an array. +-- +-- If the index @n is out of bounds, an error is raised. +index :: Array ty -> Offset ty -> ty +index array n + | isOutOfBound n len = outOfBound OOB_Index n len + | otherwise = unsafeIndex array n + where len = length array +{-# INLINE index #-} + +-- | Return the element at a specific index from an array without bounds checking. +-- +-- Reading from invalid memory can return unpredictable and invalid values. +-- use 'index' if unsure. +unsafeIndex :: Array ty -> Offset ty -> ty +unsafeIndex (Array start _ a) ofs = primArrayIndex a (start+ofs) +{-# INLINE unsafeIndex #-} + +-- | read a cell in a mutable array. +-- +-- If the index is out of bounds, an error is raised. +read :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> prim ty +read array n + | isOutOfBound n len = primOutOfBound OOB_Read n len + | otherwise = unsafeRead array n + where len = mutableLengthSize array +{-# INLINE read #-} + +-- | read from a cell in a mutable array without bounds checking. +-- +-- Reading from invalid memory can return unpredictable and invalid values. +-- use 'read' if unsure. +unsafeRead :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> prim ty +unsafeRead (MArray start _ ma) i = primMutableArrayRead ma (start + i) +{-# INLINE unsafeRead #-} + +-- | Write to a cell in a mutable array. +-- +-- If the index is out of bounds, an error is raised. +write :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> ty -> prim () +write array n val + | isOutOfBound n len = primOutOfBound OOB_Write n len + | otherwise = unsafeWrite array n val + where len = mutableLengthSize array +{-# INLINE write #-} + +-- | write to a cell in a mutable array without bounds checking. +-- +-- Writing with invalid bounds will corrupt memory and your program will +-- become unreliable. use 'write' if unsure. +unsafeWrite :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> ty -> prim () +unsafeWrite (MArray start _ ma) ofs v = + primMutableArrayWrite ma (start + ofs) v +{-# INLINE unsafeWrite #-} + +-- | Freeze a mutable array into an array. +-- +-- the MArray must not be changed after freezing. +unsafeFreeze :: PrimMonad prim => MArray ty (PrimState prim) -> prim (Array ty) +unsafeFreeze (MArray ofs sz ma) = primitive $ \s1 -> + case unsafeFreezeArray# ma s1 of + (# s2, a #) -> (# s2, Array ofs sz a #) +{-# INLINE unsafeFreeze #-} + +-- | Thaw an immutable array. +-- +-- The Array must not be used after thawing. +unsafeThaw :: PrimMonad prim => Array ty -> prim (MArray ty (PrimState prim)) +unsafeThaw (Array ofs sz a) = primitive $ \st -> (# st, MArray ofs sz (unsafeCoerce# a) #) +{-# INLINE unsafeThaw #-} + +-- | Thaw an array to a mutable array. +-- +-- the array is not modified, instead a new mutable array is created +-- and every values is copied, before returning the mutable array. +thaw :: PrimMonad prim => Array ty -> prim (MArray ty (PrimState prim)) +thaw array = do + m <- new (length array) + unsafeCopyAtRO m (Offset 0) array (Offset 0) (length array) + pure m +{-# INLINE thaw #-} + +freeze :: PrimMonad prim => MArray ty (PrimState prim) -> prim (Array ty) +freeze marray = do + m <- new sz + copyAt m (Offset 0) marray (Offset 0) sz + unsafeFreeze m + where + sz = mutableLengthSize marray + +-- | Copy the element to a new element array +copy :: Array ty -> Array ty +copy a = runST (unsafeThaw a >>= freeze) + +-- | Copy a number of elements from an array to another array with offsets +copyAt :: PrimMonad prim + => MArray ty (PrimState prim) -- ^ destination array + -> Offset ty -- ^ offset at destination + -> MArray ty (PrimState prim) -- ^ source array + -> Offset ty -- ^ offset at source + -> CountOf ty -- ^ number of elements to copy + -> prim () +copyAt dst od src os n = loop od os + where -- !endIndex = os `offsetPlusE` n + loop d s + | s .==# n = pure () + | otherwise = unsafeRead src s >>= unsafeWrite dst d >> loop (d+1) (s+1) + +-- | Copy @n@ sequential elements from the specified offset in a source array +-- to the specified position in a destination array. +-- +-- This function does not check bounds. Accessing invalid memory can return +-- unpredictable and invalid values. +unsafeCopyAtRO :: PrimMonad prim + => MArray ty (PrimState prim) -- ^ destination array + -> Offset ty -- ^ offset at destination + -> Array ty -- ^ source array + -> Offset ty -- ^ offset at source + -> CountOf ty -- ^ number of elements to copy + -> prim () +unsafeCopyAtRO (MArray (Offset (I# dstart)) _ da) (Offset (I# dofs)) + (Array (Offset (I# sstart)) _ sa) (Offset (I# sofs)) + (CountOf (I# n)) = + primitive $ \st -> + (# copyArray# sa (sstart +# sofs) da (dstart +# dofs) n st, () #) + +-- | Allocate a new array with a fill function that has access to the elements of +-- the source array. +unsafeCopyFrom :: Array ty -- ^ Source array + -> CountOf ty -- ^ Length of the destination array + -> (Array ty -> Offset ty -> MArray ty s -> ST s ()) + -- ^ Function called for each element in the source array + -> ST s (Array ty) -- ^ Returns the filled new array +unsafeCopyFrom v' newLen f = new newLen >>= fill (Offset 0) f >>= unsafeFreeze + where len = length v' + endIdx = Offset 0 `offsetPlusE` len + fill i f' r' + | i == endIdx = pure r' + | otherwise = do f' v' i r' + fill (i + Offset 1) f' r' + +-- | Create a new mutable array of size @n. +-- +-- all the cells are uninitialized and could contains invalid values. +-- +-- All mutable arrays are allocated on a 64 bits aligned addresses +-- and always contains a number of bytes multiples of 64 bits. +new :: PrimMonad prim => CountOf ty -> prim (MArray ty (PrimState prim)) +new sz@(CountOf (I# n)) = primitive $ \s1 -> + case newArray# n (error "vector: internal error uninitialized vector") s1 of + (# s2, ma #) -> (# s2, MArray (Offset 0) sz ma #) + +-- | Create a new array of size @n by settings each cells through the +-- function @f. +create :: forall ty . CountOf ty -- ^ the size of the array + -> (Offset ty -> ty) -- ^ the function that set the value at the index + -> Array ty -- ^ the array created +create n initializer = runST (new n >>= iter initializer) + where + iter :: PrimMonad prim => (Offset ty -> ty) -> MArray ty (PrimState prim) -> prim (Array ty) + iter f ma = loop 0 + where + loop s + | s .==# n = unsafeFreeze ma + | otherwise = unsafeWrite ma s (f s) >> loop (s+1) + {-# INLINE loop #-} + {-# INLINE iter #-} + +----------------------------------------------------------------------- +-- higher level collection implementation +----------------------------------------------------------------------- +equal :: Eq a => Array a -> Array a -> Bool +equal a b = (len == length b) && eachEqual 0 + where + len = length a + eachEqual !i + | i .==# len = True + | unsafeIndex a i /= unsafeIndex b i = False + | otherwise = eachEqual (i+1) + +vCompare :: Ord a => Array a -> Array a -> Ordering +vCompare a b = loop 0 + where + !la = length a + !lb = length b + loop n + | n .==# la = if la == lb then EQ else LT + | n .==# lb = GT + | otherwise = + case unsafeIndex a n `compare` unsafeIndex b n of + EQ -> loop (n+1) + r -> r + +empty :: Array a +empty = runST $ onNewArray 0 (\_ s -> s) + +length :: Array a -> CountOf a +length (Array _ sz _) = sz + +vFromList :: [a] -> Array a +vFromList l = runST (new len >>= loop 0 l) + where + len = List.length l + loop _ [] ma = unsafeFreeze ma + loop i (x:xs) ma = unsafeWrite ma i x >> loop (i+1) xs ma + +-- | just like vFromList but with a length hint. +-- +-- The resulting array is guarantee to have been allocated to the length +-- specified, but the slice might point to the initialized cells only in +-- case the length is bigger than the list. +-- +-- If the length is too small, then the list is truncated. +-- +vFromListN :: forall a . CountOf a -> [a] -> Array a +vFromListN len l = runST $ do + ma <- new len + sz <- loop 0 l ma + unsafeFreezeShrink ma sz + where + -- TODO rewrite without ma as parameter + loop :: Offset a -> [a] -> MArray a s -> ST s (CountOf a) + loop i [] _ = return (offsetAsSize i) + loop i (x:xs) ma + | i .==# len = return (offsetAsSize i) + | otherwise = unsafeWrite ma i x >> loop (i+1) xs ma + +vToList :: Array a -> [a] +vToList v + | len == 0 = [] + | otherwise = fmap (unsafeIndex v) [0..sizeLastOffset len] + where !len = length v + +-- | Append 2 arrays together by creating a new bigger array +append :: Array ty -> Array ty -> Array ty +append a b = runST $ do + r <- new (la+lb) + unsafeCopyAtRO r (Offset 0) a (Offset 0) la + unsafeCopyAtRO r (sizeAsOffset la) b (Offset 0) lb + unsafeFreeze r + where la = length a + lb = length b + +concat :: [Array ty] -> Array ty +concat l = runST $ do + r <- new (mconcat $ fmap length l) + loop r (Offset 0) l + unsafeFreeze r + where loop _ _ [] = pure () + loop r i (x:xs) = do + unsafeCopyAtRO r i x (Offset 0) lx + loop r (i `offsetPlusE` lx) xs + where lx = length x + +{- +modify :: PrimMonad m + => Array a + -> (MArray (PrimState m) a -> m ()) + -> m (Array a) +modify (Array a) f = primitive $ \st -> do + case thawArray# a 0# (sizeofArray# a) st of + (# st2, mv #) -> + case internal_ (f $ MArray mv) st2 of + st3 -> + case unsafeFreezeArray# mv st3 of + (# st4, a' #) -> (# st4, Array a' #) +-} + +----------------------------------------------------------------------- +-- helpers + +onNewArray :: PrimMonad m + => Int + -> (MutableArray# (PrimState m) a -> State# (PrimState m) -> State# (PrimState m)) + -> m (Array a) +onNewArray len@(I# len#) f = primitive $ \st -> do + case newArray# len# (error "onArray") st of { (# st2, mv #) -> + case f mv st2 of { st3 -> + case unsafeFreezeArray# mv st3 of { (# st4, a #) -> + (# st4, Array (Offset 0) (CountOf len) a #) }}} + +----------------------------------------------------------------------- + + +null :: Array ty -> Bool +null = (==) 0 . length + +take :: CountOf ty -> Array ty -> Array ty +take nbElems a@(Array start len arr) + | nbElems <= 0 = empty + | n == len = a + | otherwise = Array start n arr + where + n = min nbElems len + +drop :: CountOf ty -> Array ty -> Array ty +drop nbElems a@(Array start len arr) + | nbElems <= 0 = a + | Just nbTails <- len - nbElems, nbTails > 0 = Array (start `offsetPlusE` nbElems) nbTails arr + | otherwise = empty + +splitAt :: CountOf ty -> Array ty -> (Array ty, Array ty) +splitAt nbElems a@(Array start len arr) + | nbElems <= 0 = (empty, a) + | Just nbTails <- len - nbElems, nbTails > 0 = ( Array start nbElems arr + , Array (start `offsetPlusE` nbElems) nbTails arr) + | otherwise = (a, empty) + +-- inverse a CountOf that is specified from the end (e.g. take n elements from the end) +countFromStart :: Array ty -> CountOf ty -> CountOf ty +countFromStart v sz@(CountOf sz') + | sz >= len = CountOf 0 + | otherwise = CountOf (len' - sz') + where len@(CountOf len') = length v + +revTake :: CountOf ty -> Array ty -> Array ty +revTake n v = drop (countFromStart v n) v + +revDrop :: CountOf ty -> Array ty -> Array ty +revDrop n v = take (countFromStart v n) v + +revSplitAt :: CountOf ty -> Array ty -> (Array ty, Array ty) +revSplitAt n v = (drop idx v, take idx v) where idx = countFromStart v n + +splitOn :: (ty -> Bool) -> Array ty -> [Array ty] +splitOn predicate vec + | len == CountOf 0 = [mempty] + | otherwise = loop (Offset 0) (Offset 0) + where + !len = length vec + !endIdx = Offset 0 `offsetPlusE` len + loop prevIdx idx + | idx == endIdx = [sub vec prevIdx idx] + | otherwise = + let e = unsafeIndex vec idx + idx' = idx + 1 + in if predicate e + then sub vec prevIdx idx : loop idx' idx' + else loop prevIdx idx' + +sub :: Array ty -> Offset ty -> Offset ty -> Array ty +sub (Array start len a) startIdx expectedEndIdx + | startIdx == endIdx = empty + | otherwise = Array (start + startIdx) newLen a + where + newLen = endIdx - startIdx + endIdx = min expectedEndIdx (sizeAsOffset len) + +break :: (ty -> Bool) -> Array ty -> (Array ty, Array ty) +break predicate v = findBreak 0 + where + !len = length v + findBreak i + | i .==# len = (v, empty) + | otherwise = + if predicate (unsafeIndex v i) + then splitAt (offsetAsSize i) v + else findBreak (i+1) + +breakEnd :: (ty -> Bool) -> Array ty -> (Array ty, Array ty) +breakEnd predicate v = findBreak (sizeAsOffset len) + where + !len = length v + findBreak !i + | i == 0 = (v, empty) + | predicate e = splitAt (offsetAsSize i) v + | otherwise = findBreak i' + where + e = unsafeIndex v i' + i' = i `offsetSub` 1 + +intersperse :: ty -> Array ty -> Array ty +intersperse sep v = case len - 1 of + Nothing -> v + Just 0 -> v + Just more -> runST $ unsafeCopyFrom v (len + more) (go (Offset 0 `offsetPlusE` more) sep) + where len = length v + -- terminate 1 before the end + + go :: Offset ty -> ty -> Array ty -> Offset ty -> MArray ty s -> ST s () + go endI sep' oldV oldI newV + | oldI == endI = unsafeWrite newV dst e + | otherwise = do + unsafeWrite newV dst e + unsafeWrite newV (dst + 1) sep' + where + e = unsafeIndex oldV oldI + dst = oldI + oldI + +span :: (ty -> Bool) -> Array ty -> (Array ty, Array ty) +span p = break (not . p) + +spanEnd :: (ty -> Bool) -> Array ty -> (Array ty, Array ty) +spanEnd p = breakEnd (not . p) + +map :: (a -> b) -> Array a -> Array b +map f a = create (sizeCast Proxy $ length a) (\i -> f $ unsafeIndex a (offsetCast Proxy i)) + +mapFromUnboxed :: PrimType a => (a -> b) -> UArray a -> Array b +mapFromUnboxed f arr = vFromListN (sizeCast Proxy $ UArray.length arr) . fmap f . toList $ arr + +mapToUnboxed :: PrimType b => (a -> b) -> Array a -> UArray b +mapToUnboxed f arr = UArray.vFromListN (sizeCast Proxy $ length arr) . fmap f . toList $ arr + +{- +mapIndex :: (Int -> a -> b) -> Array a -> Array b +mapIndex f a = create (length a) (\i -> f i $ unsafeIndex a i) +-} + +singleton :: ty -> Array ty +singleton e = runST $ do + a <- new 1 + unsafeWrite a 0 e + unsafeFreeze a + +replicate :: CountOf ty -> ty -> Array ty +replicate sz ty = create sz (const ty) + +cons :: ty -> Array ty -> Array ty +cons e vec + | len == CountOf 0 = singleton e + | otherwise = runST $ do + mv <- new (len + CountOf 1) + unsafeWrite mv 0 e + unsafeCopyAtRO mv (Offset 1) vec (Offset 0) len + unsafeFreeze mv + where + !len = length vec + +snoc :: Array ty -> ty -> Array ty +snoc vec e + | len == 0 = singleton e + | otherwise = runST $ do + mv <- new (len + 1) + unsafeCopyAtRO mv 0 vec 0 len + unsafeWrite mv (sizeAsOffset len) e + unsafeFreeze mv + where + !len = length vec + +uncons :: Array ty -> Maybe (ty, Array ty) +uncons vec + | len == 0 = Nothing + | otherwise = Just (unsafeIndex vec 0, drop 1 vec) + where + !len = length vec + +unsnoc :: Array ty -> Maybe (Array ty, ty) +unsnoc vec = case len - 1 of + Nothing -> Nothing + Just newLen -> Just (take newLen vec, unsafeIndex vec (sizeLastOffset len)) + where + !len = length vec + +elem :: Eq ty => ty -> Array ty -> Bool +elem !ty arr = loop 0 + where + !sz = length arr + loop !i | i .==# sz = False + | t == ty = True + | otherwise = loop (i+1) + where t = unsafeIndex arr i + +find :: (ty -> Bool) -> Array ty -> Maybe ty +find predicate vec = loop 0 + where + !len = length vec + loop i + | i .==# len = Nothing + | otherwise = + let e = unsafeIndex vec i + in if predicate e then Just e else loop (i+1) + +instance (PrimMonad prim, st ~ PrimState prim) + => Alg.RandomAccess (MArray ty st) prim ty where + read (MArray _ _ mba) = primMutableArrayRead mba + write (MArray _ _ mba) = primMutableArrayWrite mba + +sortBy :: forall ty . (ty -> ty -> Ordering) -> Array ty -> Array ty +sortBy xford vec + | len == 0 = empty + | otherwise = runST (thaw vec >>= doSort xford) + where + len = length vec + doSort :: PrimMonad prim => (ty -> ty -> Ordering) -> MArray ty (PrimState prim) -> prim (Array ty) + doSort ford ma = Alg.inplaceSortBy ford 0 len ma >> unsafeFreeze ma + +filter :: forall ty . (ty -> Bool) -> Array ty -> Array ty +filter predicate vec = runST (new len >>= copyFilterFreeze predicate (unsafeIndex vec)) + where + !len = length vec + copyFilterFreeze :: PrimMonad prim => (ty -> Bool) -> (Offset ty -> ty) -> MArray ty (PrimState prim) -> prim (Array ty) + copyFilterFreeze predi getVec mvec = loop (Offset 0) (Offset 0) >>= freezeUntilIndex mvec + where + loop d s + | s .==# len = pure d + | predi v = unsafeWrite mvec d v >> loop (d+1) (s+1) + | otherwise = loop d (s+1) + where + v = getVec s + +freezeUntilIndex :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> prim (Array ty) +freezeUntilIndex mvec d = do + m <- new (offsetAsSize d) + copyAt m (Offset 0) mvec (Offset 0) (offsetAsSize d) + unsafeFreeze m + +unsafeFreezeShrink :: PrimMonad prim => MArray ty (PrimState prim) -> CountOf ty -> prim (Array ty) +unsafeFreezeShrink (MArray start _ ma) n = unsafeFreeze (MArray start n ma) + +reverse :: Array ty -> Array ty +reverse a = create len toEnd + where + len@(CountOf s) = length a + toEnd (Offset i) = unsafeIndex a (Offset (s - 1 - i)) + +foldr :: (ty -> a -> a) -> a -> Array ty -> a +foldr f initialAcc vec = loop 0 + where + len = length vec + loop !i + | i .==# len = initialAcc + | otherwise = unsafeIndex vec i `f` loop (i+1) + +foldl' :: (a -> ty -> a) -> a -> Array ty -> a +foldl' f initialAcc vec = loop 0 initialAcc + where + len = length vec + loop !i !acc + | i .==# len = acc + | otherwise = loop (i+1) (f acc (unsafeIndex vec i)) + +foldl1' :: (ty -> ty -> ty) -> NonEmpty (Array ty) -> ty +foldl1' f arr = let (initialAcc, rest) = splitAt 1 $ getNonEmpty arr + in foldl' f (unsafeIndex initialAcc 0) rest + +foldr1 :: (ty -> ty -> ty) -> NonEmpty (Array ty) -> ty +foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr + in foldr f (unsafeIndex initialAcc 0) rest + +all :: (ty -> Bool) -> Array ty -> Bool +all p ba = loop 0 + where + len = length ba + loop !i + | i .==# len = True + | not $ p (unsafeIndex ba i) = False + | otherwise = loop (i + 1) + +any :: (ty -> Bool) -> Array ty -> Bool +any p ba = loop 0 + where + len = length ba + loop !i + | i .==# len = False + | p (unsafeIndex ba i) = True + | otherwise = loop (i + 1) + +isPrefixOf :: Eq ty => Array ty -> Array ty -> Bool +isPrefixOf pre arr + | pLen > pArr = False + | otherwise = pre == take pLen arr + where + !pLen = length pre + !pArr = length arr + +isSuffixOf :: Eq ty => Array ty -> Array ty -> Bool +isSuffixOf suffix arr + | pLen > pArr = False + | otherwise = suffix == revTake pLen arr + where + !pLen = length suffix + !pArr = length arr + +builderAppend :: PrimMonad state => ty -> Builder (Array ty) (MArray ty) ty state err () +builderAppend v = Builder $ State $ \(i, st, e) -> + if i .==# chunkSize st + then do + cur <- unsafeFreeze (curChunk st) + newChunk <- new (chunkSize st) + unsafeWrite newChunk 0 v + pure ((), (Offset 1, st { prevChunks = cur : prevChunks st + , prevChunksSize = chunkSize st + prevChunksSize st + , curChunk = newChunk + }, e)) + else do + unsafeWrite (curChunk st) i v + pure ((), (i+1, st, e)) + +builderBuild :: PrimMonad m => Int -> Builder (Array ty) (MArray ty) ty m err () -> m (Either err (Array ty)) +builderBuild sizeChunksI ab + | sizeChunksI <= 0 = builderBuild 64 ab + | otherwise = do + first <- new sizeChunks + (i, st, e) <- snd <$> runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks, Nothing) + case e of + Just err -> pure (Left err) + Nothing -> do + cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i) + -- Build final array + let totalSize = prevChunksSize st + offsetAsSize i + bytes <- new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze + pure (Right bytes) + where + sizeChunks = CountOf sizeChunksI + + fillFromEnd _ [] mua = pure mua + fillFromEnd !end (x:xs) mua = do + let sz = length x + let start = end `sizeSub` sz + unsafeCopyAtRO mua (sizeAsOffset start) x (Offset 0) sz + fillFromEnd start xs mua + +builderBuild_ :: PrimMonad m => Int -> Builder (Array ty) (MArray ty) ty m () () -> m (Array ty) +builderBuild_ sizeChunksI ab = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI ab diff --git a/bundled/Basement/Cast.hs b/bundled/Basement/Cast.hs new file mode 100644 index 0000000..2c20404 --- /dev/null +++ b/bundled/Basement/Cast.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Basement.Cast +-- License : BSD-style +-- Maintainer : Haskell Foundation +-- +module Basement.Cast + ( Cast(..) + ) where + +#include "MachDeps.h" + +import qualified Basement.Block.Base as Block +import Basement.Compat.Base +import Basement.Compat.Natural +import Basement.Compat.Primitive +import Basement.Numerical.Number +import Basement.Numerical.Conversion +import Basement.PrimType + +import Data.Proxy (Proxy(..)) + +import GHC.Int +import GHC.Prim +import GHC.Types +import GHC.ST +import GHC.Word + +-- | `Cast` an object of type a to b. +-- +-- Do not add instance of this class if the source type is not of the same +-- size of the destination type. Also keep in mind this is casting a value +-- of a given type into a destination type. The value won't be changed to +-- fit the destination represention. +-- +-- If you wish to convert a value of a given type into another type, look at +-- `From` and `TryFrom`. +-- +-- @ +-- cast (-10 :: Int) :: Word === 18446744073709551606 +-- @ +-- +class Cast source destination where + cast :: source -> destination + + default cast :: ( PrimType source + , PrimType destination + , PrimSize source ~ PrimSize destination + ) + => source -> destination + cast a = runST $ do + mba <- Block.new 1 + Block.unsafeWrite mba 0 a + Block.unsafeRead (Block.unsafeRecast mba) 0 + +instance Cast Int8 Word8 where + cast (I8# i) = W8# (wordToWord8# (int2Word# (int8ToInt# i))) +instance Cast Int16 Word16 where + cast (I16# i) = W16# (wordToWord16# (int2Word# (int16ToInt# i))) +instance Cast Int32 Word32 where + cast (I32# i) = W32# (wordToWord32# (int2Word# (int32ToInt# i))) +instance Cast Int64 Word64 where + cast = int64ToWord64 +instance Cast Int Word where + cast (I# i) = W# (int2Word# i) + +instance Cast Word8 Int8 where + cast (W8# i) = I8# (intToInt8# (word2Int# (word8ToWord# i))) +instance Cast Word16 Int16 where + cast (W16# i) = I16# (intToInt16# (word2Int# (word16ToWord# i))) +instance Cast Word32 Int32 where + cast (W32# i) = I32# (intToInt32# (word2Int# (word32ToWord# i))) +instance Cast Word64 Int64 where + cast = word64ToInt64 +instance Cast Word Int where + cast (W# w) = I# (word2Int# w) + +#if WORD_SIZE_IN_BITS == 64 +#if __GLASGOW_HASKELL__ >= 904 +instance Cast Word Word64 where + cast (W# w) = W64# (wordToWord64# w) +instance Cast Word64 Word where + cast (W64# w) = W# (GHC.Prim.word64ToWord# w) + +instance Cast Word Int64 where + cast (W# w) = I64# (intToInt64# (word2Int# w)) +instance Cast Int64 Word where + cast (I64# i) = W# (int2Word# (int64ToInt# i)) + +instance Cast Int Int64 where + cast (I# i) = I64# (intToInt64# i) +instance Cast Int64 Int where + cast (I64# i) = I# (int64ToInt# i) + +instance Cast Int Word64 where + cast (I# i) = W64# (wordToWord64# (int2Word# i)) +instance Cast Word64 Int where + cast (W64# w) = I# (word2Int# (GHC.Prim.word64ToWord# w)) +#else +instance Cast Word Word64 where + cast (W# w) = W64# w +instance Cast Word64 Word where + cast (W64# w) = W# w + +instance Cast Word Int64 where + cast (W# w) = I64# (word2Int# w) +instance Cast Int64 Word where + cast (I64# i) = W# (int2Word# i) + +instance Cast Int Int64 where + cast (I# i) = I64# i +instance Cast Int64 Int where + cast (I64# i) = I# i + +instance Cast Int Word64 where + cast (I# i) = W64# (int2Word# i) +instance Cast Word64 Int where + cast (W64# w) = I# (word2Int# w) +#endif +#else +instance Cast Word Word32 where + cast (W# w) = W32# (wordToWord32# w) +instance Cast Word32 Word where + cast (W32# w) = W# (word32ToWord# w) + +instance Cast Word Int32 where + cast (W# w) = I32# (intToInt32# (word2Int# w)) +instance Cast Int32 Word where + cast (I32# i) = W# (int2Word# (int32ToInt# i)) + +instance Cast Int Int32 where + cast (I# i) = I32# (intToInt32# i) +instance Cast Int32 Int where + cast (I32# i) = I# (int32ToInt# i) + +instance Cast Int Word32 where + cast (I# i) = W32# (wordToWord32# (int2Word# i)) +instance Cast Word32 Int where + cast (W32# w) = I# (word2Int# (word32ToWord# w)) +#endif + +instance Cast (Block.Block a) (Block.Block Word8) where + cast (Block.Block ba) = Block.Block ba diff --git a/bundled/Basement/Compat/AMP.hs b/bundled/Basement/Compat/AMP.hs new file mode 100644 index 0000000..8b3b49c --- /dev/null +++ b/bundled/Basement/Compat/AMP.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +-- a compat module for ghc < 7.10 to handle the AMP change smoothly +module Basement.Compat.AMP + ( AMPMonad + ) where + +import Basement.Compat.Base + +{-# DEPRECATED AMPMonad "use Monad" #-} +type AMPMonad m = Monad m diff --git a/bundled/Basement/Compat/Base.hs b/bundled/Basement/Compat/Base.hs new file mode 100644 index 0000000..1b59578 --- /dev/null +++ b/bundled/Basement/Compat/Base.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Compat.Base +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- internal re-export of all the good base bits +module Basement.Compat.Base + ( (Prelude.$) + , (Prelude.$!) + , (Prelude.&&) + , (Prelude.||) + , (Control.Category..) + , (Control.Applicative.<$>) + , Prelude.not + , Prelude.otherwise + , Prelude.fst + , Prelude.snd + , Control.Category.id + , Prelude.maybe + , Prelude.either + , Prelude.flip + , Prelude.const + , Prelude.error + , Prelude.and + , Prelude.undefined + , Prelude.seq + , Prelude.Show (..) + , Prelude.Ord (..) + , Prelude.Eq (..) + , Prelude.Bounded (..) + , Prelude.Enum (..) + , Prelude.Functor (..) + , Control.Applicative.Applicative (..) + , Prelude.Monad (..) + , Control.Monad.when + , Control.Monad.unless + , Prelude.Maybe (..) + , Prelude.Ordering (..) + , Prelude.Bool (..) + , Prelude.Int + , Prelude.Integer + , Prelude.Char + , Basement.Compat.NumLiteral.Integral (..) + , Basement.Compat.NumLiteral.Fractional (..) + , Basement.Compat.NumLiteral.HasNegation (..) + , Data.Int.Int8, Data.Int.Int16, Data.Int.Int32, Data.Int.Int64 + , Data.Word.Word8, Data.Word.Word16, Data.Word.Word32, Data.Word.Word64, Data.Word.Word + , Prelude.Double, Prelude.Float + , Prelude.IO + , Basement.Compat.IsList.IsList (..) + , GHC.Exts.IsString (..) + , GHC.Generics.Generic + , Prelude.Either (..) + , Data.Data.Data (..) + , Data.Data.mkNoRepType + , Data.Data.DataType + , Basement.Compat.Typeable.Typeable + , Data.Monoid.Monoid (..) + , (Data.Monoid.<>) + , Control.Exception.Exception + , Control.Exception.throw + , Control.Exception.throwIO + , GHC.Ptr.Ptr(..) + , ifThenElse + , internalError + ) where + +import qualified Prelude +import qualified Control.Category +import qualified Control.Applicative +import qualified Control.Exception +import qualified Control.Monad +import qualified Data.Monoid +import qualified Data.Data +import qualified Data.Word +import qualified Data.Int +import qualified Basement.Compat.IsList +import qualified Basement.Compat.NumLiteral +import qualified Basement.Compat.Typeable +import qualified GHC.Exts +import qualified GHC.Generics +import qualified GHC.Ptr +import GHC.Exts (fromString) + +-- | Only to use internally for internal error cases +internalError :: [Prelude.Char] -> a +internalError s = Prelude.error ("Internal Error: the impossible happened: " Prelude.++ s) + +-- | for support of if .. then .. else +ifThenElse :: Prelude.Bool -> a -> a -> a +ifThenElse Prelude.True e1 _ = e1 +ifThenElse Prelude.False _ e2 = e2 diff --git a/bundled/Basement/Compat/Bifunctor.hs b/bundled/Basement/Compat/Bifunctor.hs new file mode 100644 index 0000000..456d464 --- /dev/null +++ b/bundled/Basement/Compat/Bifunctor.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Compat.Bifunctor +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- A bifunctor is a type constructor that takes +-- two type arguments and is a functor in /both/ arguments. That +-- is, unlike with 'Functor', a type constructor such as 'Either' +-- does not need to be partially applied for a 'Bifunctor' +-- instance, and the methods in this class permit mapping +-- functions over the 'Left' value or the 'Right' value, +-- or both at the same time. +-- +-- Formally, the class 'Bifunctor' represents a bifunctor +-- from @Hask@ -> @Hask@. +-- +-- Intuitively it is a bifunctor where both the first and second +-- arguments are covariant. +-- +-- You can define a 'Bifunctor' by either defining 'bimap' or by +-- defining both 'first' and 'second'. +-- +{-# LANGUAGE CPP #-} +module Basement.Compat.Bifunctor + ( Bifunctor(..) + ) where + +#if MIN_VERSION_base(4,8,0) + +import Data.Bifunctor (Bifunctor(..)) + +#else + +import Control.Applicative ( Const(..) ) +import GHC.Generics ( K1(..) ) +import qualified Prelude as P + +class Bifunctor p where + {-# MINIMAL bimap | first, second #-} + + -- | Map over both arguments at the same time. + -- + -- @'bimap' f g ≡ 'first' f '.' 'second' g@ + -- + -- ==== __Examples__ + -- + -- >>> bimap toUpper (+1) ('j', 3) + -- ('J',4) + -- + -- >>> bimap toUpper (+1) (Left 'j') + -- Left 'J' + -- + -- >>> bimap toUpper (+1) (Right 3) + -- Right 4 + bimap :: (a -> b) -> (c -> d) -> p a c -> p b d + bimap f g = first f P.. second g + + -- | Map covariantly over the first argument. + -- + -- @'first' f ≡ 'bimap' f 'id'@ + -- + -- ==== __Examples__ + -- + -- >>> first toUpper ('j', 3) + -- ('J',3) + -- + -- >>> first toUpper (Left 'j') + -- Left 'J' + first :: (a -> b) -> p a c -> p b c + first f = bimap f P.id + + -- | Map covariantly over the second argument. + -- + -- @'second' ≡ 'bimap' 'id'@ + -- + -- ==== __Examples__ + -- >>> second (+1) ('j', 3) + -- ('j',4) + -- + -- >>> second (+1) (Right 3) + -- Right 4 + second :: (b -> c) -> p a b -> p a c + second = bimap P.id + + +instance Bifunctor (,) where + bimap f g ~(a, b) = (f a, g b) + +instance Bifunctor ((,,) x1) where + bimap f g ~(x1, a, b) = (x1, f a, g b) + +instance Bifunctor ((,,,) x1 x2) where + bimap f g ~(x1, x2, a, b) = (x1, x2, f a, g b) + +instance Bifunctor ((,,,,) x1 x2 x3) where + bimap f g ~(x1, x2, x3, a, b) = (x1, x2, x3, f a, g b) + +instance Bifunctor ((,,,,,) x1 x2 x3 x4) where + bimap f g ~(x1, x2, x3, x4, a, b) = (x1, x2, x3, x4, f a, g b) + +instance Bifunctor ((,,,,,,) x1 x2 x3 x4 x5) where + bimap f g ~(x1, x2, x3, x4, x5, a, b) = (x1, x2, x3, x4, x5, f a, g b) + + +instance Bifunctor P.Either where + bimap f _ (P.Left a) = P.Left (f a) + bimap _ g (P.Right b) = P.Right (g b) + +instance Bifunctor Const where + bimap f _ (Const a) = Const (f a) + +instance Bifunctor (K1 i) where + bimap f _ (K1 c) = K1 (f c) + +#endif diff --git a/bundled/Basement/Compat/C/Types.hs b/bundled/Basement/Compat/C/Types.hs new file mode 100644 index 0000000..e2e2d0a --- /dev/null +++ b/bundled/Basement/Compat/C/Types.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# Language CPP #-} +-- | +-- Module : Basement.Compat.C.Types +-- License : BSD-style +-- Maintainer : Foundation +-- +-- Literal support for Integral and Fractional +-- {-# LANGUAGE TypeSynonymInstances #-} +-- {-# LANGUAGE FlexibleInstances #-} +module Basement.Compat.C.Types + ( CChar(..), CSChar(..), CUChar(..) + , CShort(..), CUShort(..), CInt(..), CUInt(..), CLong(..), CULong(..) + , CPtrdiff(..), CSize(..), CWchar(..), CSigAtomic(..), CLLong(..), CULLong(..) +#if MIN_VERSION_base(4,10,0) + , CBool(..) +#endif + , CIntPtr(..), CUIntPtr(..), CIntMax(..), CUIntMax(..) + , CClock(..), CTime(..), CUSeconds(..), CSUSeconds(..), CFloat(..), CDouble + , COff(..), CMode(..) + ) where + +import Foreign.C.Types +import System.Posix.Types diff --git a/bundled/Basement/Compat/CallStack.hs b/bundled/Basement/Compat/CallStack.hs new file mode 100644 index 0000000..7ae059c --- /dev/null +++ b/bundled/Basement/Compat/CallStack.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ConstraintKinds #-} +module Basement.Compat.CallStack + ( HasCallStack + ) where + +#if MIN_VERSION_base(4,9,0) + +import GHC.Stack (HasCallStack) + +#elif MIN_VERSION_base(4,8,1) + +import qualified GHC.Stack + +type HasCallStack = (?callStack :: GHC.Stack.CallStack) + +#else + +import GHC.Exts (Constraint) + +type HasCallStack = (() :: Constraint) + +#endif diff --git a/bundled/Basement/Compat/ExtList.hs b/bundled/Basement/Compat/ExtList.hs new file mode 100644 index 0000000..8008ac6 --- /dev/null +++ b/bundled/Basement/Compat/ExtList.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +module Basement.Compat.ExtList + ( length + , null + , sum + , reverse + , (!!) + ) where + +import Basement.Compat.Base +import Basement.Numerical.Additive +import Basement.Types.OffsetSize +import qualified GHC.List as List + +-- | Compute the size of the list +length :: [a] -> CountOf a +#if MIN_VERSION_base(4,8,0) +length = CountOf . List.foldl' (\c _ -> c+1) 0 +#else +length = CountOf . loop 0 + where loop !acc [] = acc + loop !acc (_:xs) = loop (1+acc) xs +#endif + +null :: [a] -> Bool +null [] = True +null (_:_) = False + +-- | Sum the element in a list +sum :: Additive n => [n] -> n +sum [] = azero +sum (i:is) = loop i is + where + loop !acc [] = acc + loop !acc (x:xs) = loop (acc+x) xs + {-# INLINE loop #-} + +reverse :: [a] -> [a] +reverse l = go l [] + where + go [] acc = acc + go (x:xs) acc = go xs (x:acc) + +(!!) :: [a] -> Offset a -> a +[] !! _ = error "invalid offset for !!" +(x:_) !! 0 = x +(_:xs) !! i = xs !! pred i diff --git a/bundled/Basement/Compat/Identity.hs b/bundled/Basement/Compat/Identity.hs new file mode 100644 index 0000000..f387a51 --- /dev/null +++ b/bundled/Basement/Compat/Identity.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Compat.Identity +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- Identity re-export, with a compat wrapper for older version of base that +-- do not have Data.Functor.Identity +{-# LANGUAGE CPP #-} +module Basement.Compat.Identity + ( Identity(..) + ) where + +#if MIN_VERSION_base(4,8,0) + +import Data.Functor.Identity + +#else + +import Basement.Compat.Base + +newtype Identity a = Identity { runIdentity :: a } + deriving (Eq, Ord) + +instance Functor Identity where + fmap f (Identity a) = Identity (f a) + +instance Applicative Identity where + pure a = Identity a + (<*>) fab fa = Identity $ runIdentity fab (runIdentity fa) + +instance Monad Identity where + return = pure + ma >>= mb = mb (runIdentity ma) + +#endif diff --git a/bundled/Basement/Compat/IsList.hs b/bundled/Basement/Compat/IsList.hs new file mode 100644 index 0000000..1d779fe --- /dev/null +++ b/bundled/Basement/Compat/IsList.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Compat.IsList +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- compat friendly version of IsList +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +module Basement.Compat.IsList + ( IsList(..) + ) where + +#if MIN_VERSION_base(4,7,0) + +import GHC.Exts + +#else + +import qualified Prelude + +class IsList l where + type Item l + fromList :: [Item l] -> l + toList :: l -> [Item l] + + fromListN :: Prelude.Int -> [Item l] -> l + fromListN _ = fromList + +instance IsList [a] where + type Item [a] = a + fromList = Prelude.id + toList = Prelude.id + +#endif diff --git a/bundled/Basement/Compat/MonadTrans.hs b/bundled/Basement/Compat/MonadTrans.hs new file mode 100644 index 0000000..6cfb3d1 --- /dev/null +++ b/bundled/Basement/Compat/MonadTrans.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Compat.MonadTrans +-- License : BSD-style +-- Maintainer : Psychohistorians +-- Stability : experimental +-- Portability : portable +-- +-- An internal and really simple monad transformers, +-- without any bells and whistse. +module Basement.Compat.MonadTrans + ( State(..) + , Reader(..) + ) where + +import Basement.Compat.Base +import Control.Monad ((>=>)) + +-- | Simple State monad +newtype State s m a = State { runState :: s -> m (a, s) } + +instance Monad m => Functor (State s m) where + fmap f fa = State $ runState fa >=> (\(a, s2) -> return (f a, s2)) +instance Monad m => Applicative (State s m) where + pure a = State $ \st -> return (a,st) + fab <*> fa = State $ \s1 -> do + (ab,s2) <- runState fab s1 + (a,s3) <- runState fa s2 + return (ab a, s3) +instance Monad m => Monad (State r m) where + return = pure + ma >>= mb = State $ \s1 -> do + (a,s2) <- runState ma s1 + runState (mb a) s2 + +-- | Simple Reader monad +newtype Reader r m a = Reader { runReader :: r -> m a } + +instance Monad m => Functor (Reader r m) where + fmap f fa = Reader $ runReader fa >=> (\a -> return (f a)) +instance Monad m => Applicative (Reader r m) where + pure a = Reader $ \_ -> return a + fab <*> fa = Reader $ \r -> do + a <- runReader fa r + ab <- runReader fab r + return $ ab a +instance Monad m => Monad (Reader r m) where + return = pure + ma >>= mb = Reader $ \r -> do + a <- runReader ma r + runReader (mb a) r diff --git a/bundled/Basement/Compat/Natural.hs b/bundled/Basement/Compat/Natural.hs new file mode 100644 index 0000000..b50ea52 --- /dev/null +++ b/bundled/Basement/Compat/Natural.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Basement.Compat.Natural + ( Natural + , integerToNatural + , naturalToInteger + ) where + +#if MIN_VERSION_base(4,8,0) + +import Numeric.Natural +import Prelude (Integer, abs, fromInteger, toInteger) + +#else + +import Prelude (Show(..),Eq,Ord,Enum,Num(..),Real(..),Integral(..),Integer,error,(<), (>), otherwise, toInteger) +import Data.Bits +import Data.Typeable + +newtype Natural = Natural Integer + deriving (Eq,Ord,Enum,Typeable,Bits) + +instance Show Natural where + show (Natural i) = show i + +-- re-create the buggy Num instance for Natural +instance Num Natural where + fromInteger n + | n < 0 = error "natural should be positive: " + | otherwise = Natural n + (+) (Natural a) (Natural b) = Natural (a + b) + (-) (Natural a) (Natural b) + | r < 0 = error "natural should be positve" + | otherwise = Natural (a - b) + where r = (a - b) + (*) (Natural a) (Natural b) = Natural (a * b) + abs n = n + negate n = n + signum (Natural n) + | n > 0 = 1 + | otherwise = 0 + +instance Real Natural where + toRational (Natural n) = toRational n + +instance Integral Natural where + toInteger (Natural n) = n + divMod (Natural n) (Natural e) = let (a,b) = n `quotRem` e in (Natural a, Natural b) + quotRem (Natural n) (Natural e) = let (a,b) = n `quotRem` e in (Natural a, Natural b) + quot (Natural n) (Natural e) = Natural (n `quot` e) + rem (Natural n) (Natural e) = Natural (n `rem` e) + div = quot + mod = rem + +#endif + +integerToNatural :: Integer -> Natural +integerToNatural i = fromInteger (abs i) + +naturalToInteger :: Natural -> Integer +naturalToInteger n = toInteger n diff --git a/bundled/Basement/Compat/NumLiteral.hs b/bundled/Basement/Compat/NumLiteral.hs new file mode 100644 index 0000000..f663b6b --- /dev/null +++ b/bundled/Basement/Compat/NumLiteral.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# Language CPP #-} +-- | +-- Module : Basement.Compat.NumLiteral +-- License : BSD-style +-- Maintainer : Foundation +-- +-- Literal support for Integral and Fractional +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +module Basement.Compat.NumLiteral + ( Integral(..) + , Fractional(..) + , HasNegation(..) + ) where + +import Prelude (Int, Integer, Rational, Float, Double) +import Data.Word (Word8, Word16, Word32, Word64, Word) +import Data.Int (Int8, Int16, Int32, Int64) +import Basement.Compat.C.Types +import qualified Prelude +import Basement.Compat.Natural +import Foreign.Ptr (IntPtr) + +-- | Integral Literal support +-- +-- e.g. 123 :: Integer +-- 123 :: Word8 +class Integral a where + fromInteger :: Integer -> a + +-- | Fractional Literal support +-- +-- e.g. 1.2 :: Double +-- 0.03 :: Float +class Fractional a where + fromRational :: Rational -> a + +-- | Negation support +-- +-- e.g. -(f x) +class HasNegation a where + negate :: a -> a + +instance Integral Integer where + fromInteger a = a +instance Integral Natural where + fromInteger a = Prelude.fromInteger a +instance Integral Int where + fromInteger a = Prelude.fromInteger a +instance Integral Word where + fromInteger a = Prelude.fromInteger a +instance Integral Word8 where + fromInteger a = Prelude.fromInteger a +instance Integral Word16 where + fromInteger a = Prelude.fromInteger a +instance Integral Word32 where + fromInteger a = Prelude.fromInteger a +instance Integral Word64 where + fromInteger a = Prelude.fromInteger a +instance Integral Int8 where + fromInteger a = Prelude.fromInteger a +instance Integral Int16 where + fromInteger a = Prelude.fromInteger a +instance Integral Int32 where + fromInteger a = Prelude.fromInteger a +instance Integral Int64 where + fromInteger a = Prelude.fromInteger a +instance Integral IntPtr where + fromInteger a = Prelude.fromInteger a + +instance Integral Float where + fromInteger a = Prelude.fromInteger a +instance Integral Double where + fromInteger a = Prelude.fromInteger a + +instance Integral CChar where + fromInteger a = Prelude.fromInteger a +instance Integral CSChar where + fromInteger a = Prelude.fromInteger a +instance Integral CUChar where + fromInteger a = Prelude.fromInteger a +instance Integral CShort where + fromInteger a = Prelude.fromInteger a +instance Integral CUShort where + fromInteger a = Prelude.fromInteger a +instance Integral CInt where + fromInteger a = Prelude.fromInteger a +instance Integral CUInt where + fromInteger a = Prelude.fromInteger a +instance Integral CLong where + fromInteger a = Prelude.fromInteger a +instance Integral CULong where + fromInteger a = Prelude.fromInteger a +instance Integral CPtrdiff where + fromInteger a = Prelude.fromInteger a +instance Integral CSize where + fromInteger a = Prelude.fromInteger a +instance Integral CWchar where + fromInteger a = Prelude.fromInteger a +instance Integral CSigAtomic where + fromInteger a = Prelude.fromInteger a +instance Integral CLLong where + fromInteger a = Prelude.fromInteger a +instance Integral CULLong where + fromInteger a = Prelude.fromInteger a +#if MIN_VERSION_base(4, 10, 0) +instance Integral CBool where + fromInteger a = Prelude.fromInteger a +#endif +instance Integral CIntPtr where + fromInteger a = Prelude.fromInteger a +instance Integral CUIntPtr where + fromInteger a = Prelude.fromInteger a +instance Integral CIntMax where + fromInteger a = Prelude.fromInteger a +instance Integral CUIntMax where + fromInteger a = Prelude.fromInteger a +instance Integral CClock where + fromInteger a = Prelude.fromInteger a +instance Integral CTime where + fromInteger a = Prelude.fromInteger a +instance Integral CUSeconds where + fromInteger a = Prelude.fromInteger a +instance Integral CSUSeconds where + fromInteger a = Prelude.fromInteger a +instance Integral COff where + fromInteger a = Prelude.fromInteger a +instance Integral CFloat where + fromInteger a = Prelude.fromInteger a +instance Integral CDouble where + fromInteger a = Prelude.fromInteger a + +instance HasNegation Integer where + negate = Prelude.negate +instance HasNegation Int where + negate = Prelude.negate +instance HasNegation Int8 where + negate = Prelude.negate +instance HasNegation Int16 where + negate = Prelude.negate +instance HasNegation Int32 where + negate = Prelude.negate +instance HasNegation Int64 where + negate = Prelude.negate +instance HasNegation Word where + negate = Prelude.negate +instance HasNegation Word8 where + negate = Prelude.negate +instance HasNegation Word16 where + negate = Prelude.negate +instance HasNegation Word32 where + negate = Prelude.negate +instance HasNegation Word64 where + negate = Prelude.negate + +instance HasNegation Float where + negate = Prelude.negate +instance HasNegation Double where + negate = Prelude.negate + +instance HasNegation CChar where + negate = Prelude.negate +instance HasNegation CSChar where + negate = Prelude.negate +instance HasNegation CShort where + negate = Prelude.negate +instance HasNegation CInt where + negate = Prelude.negate +instance HasNegation CLong where + negate = Prelude.negate +instance HasNegation CPtrdiff where + negate = Prelude.negate +instance HasNegation CWchar where + negate = Prelude.negate +instance HasNegation CLLong where + negate = Prelude.negate +instance HasNegation CIntMax where + negate = Prelude.negate + +instance HasNegation CFloat where + negate = Prelude.negate +instance HasNegation CDouble where + negate = Prelude.negate + +instance Fractional Rational where + fromRational a = Prelude.fromRational a +instance Fractional Float where + fromRational a = Prelude.fromRational a +instance Fractional Double where + fromRational a = Prelude.fromRational a + +instance Fractional CFloat where + fromRational a = Prelude.fromRational a +instance Fractional CDouble where + fromRational a = Prelude.fromRational a diff --git a/bundled/Basement/Compat/PrimTypes.hs b/bundled/Basement/Compat/PrimTypes.hs new file mode 100644 index 0000000..be7997a --- /dev/null +++ b/bundled/Basement/Compat/PrimTypes.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Compat.PrimTypes +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +{-# LANGUAGE MagicHash #-} +module Basement.Compat.PrimTypes + ( FileSize# + , Offset# + , CountOf# + , Bool# + , Pinned# + ) where + +import GHC.Prim + +-- | File size in bytes +type FileSize# = Word64# + +-- | Offset in a bytearray, string, type alias +-- +-- for code documentation purpose only, just a simple type alias on Int# +type Offset# = Int# + +-- | CountOf in bytes type alias +-- +-- for code documentation purpose only, just a simple type alias on Int# +type CountOf# = Int# + +-- | Lowlevel Boolean +type Bool# = Int# + +-- | Pinning status +type Pinned# = Bool# diff --git a/bundled/Basement/Compat/Primitive.hs b/bundled/Basement/Compat/Primitive.hs new file mode 100644 index 0000000..7d74c80 --- /dev/null +++ b/bundled/Basement/Compat/Primitive.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Compat.Primitive +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE UnliftedFFITypes #-} +module Basement.Compat.Primitive + ( bool# + , PinnedStatus(..), toPinnedStatus# + , compatMkWeak# + , compatIsByteArrayPinned# + , compatIsMutableByteArrayPinned# + , unsafeCoerce# + , Word(..) + , Word8# + , Word16# + , Word32# + , Int8# + , Int16# + , Int32# + -- word upper sizing + , word8ToWord16# + , word8ToWord32# + , word8ToWord# + , word16ToWord8# + , word16ToWord32# + , word16ToWord# + , word32ToWord# + -- word down sizing + , word32ToWord8# + , word32ToWord16# + , wordToWord32# + , wordToWord16# + , wordToWord8# + -- int upper sizing + , int8ToInt16# + , int8ToInt32# + , int8ToInt# + , int16ToInt32# + , int16ToInt# + , int32ToInt# + -- int down sizing + , intToInt8# + , intToInt16# + , intToInt32# + -- other + , word8ToInt# + , word8ToInt16# + , word8ToInt32# + , charToWord32# + , word8ToChar# + , word16ToChar# + , word32ToChar# + , wordToChar# + + -- word8 ops + , plusWord8# + -- word16 ops + , uncheckedShiftRLWord16# + , plusWord16# + -- word32 ops + , uncheckedShiftRLWord32# + , plusWord32# + -- int8 ops + , plusInt8# + -- int16 ops + , plusInt16# + -- int32 ops + , plusInt32# + ) where + + +import qualified Prelude +import GHC.Exts hiding (Word8#, Word16#, Word32#, Int8#, Int16#, Int32#, plusWord8#, plusWord16#, plusInt8#, plusInt16#) +import GHC.Prim hiding (Word8#, Word16#, Word32#, Int8#, Int16#, Int32#, plusWord8#, plusWord16#, plusInt8#, plusInt16#) +import GHC.Word +import GHC.IO + +import Basement.Compat.PrimTypes + +#if __GLASGOW_HASKELL__ >= 902 +import GHC.Exts (Word8#, Word16#, Word32#, Int8#, Int16#, Int32#, plusWord8#, plusWord16#, plusInt8#, plusInt16#) +#endif + +-- GHC 9.2 | Base 4.16 +-- GHC 9.0 | Base 4.15 +-- GHC 8.8 | Base 4.13 4.14 +-- GHC 8.6 | Base 4.12 +-- GHC 8.4 | Base 4.11 +-- GHC 8.2 | Base 4.10 +-- GHC 8.0 | Base 4.9 +-- GHC 7.10 | Base 4.8 +-- GHC 7.8 | Base 4.7 +-- GHC 7.6 | Base 4.6 +-- GHC 7.4 | Base 4.5 +-- +-- More complete list: +-- https://wiki.haskell.org/Base_package + +-- | Flag record whether a specific byte array is pinned or not +data PinnedStatus = Pinned | Unpinned + deriving (Prelude.Eq) + +toPinnedStatus# :: Pinned# -> PinnedStatus +toPinnedStatus# 0# = Unpinned +toPinnedStatus# _ = Pinned + +-- | turn an Int# into a Bool +bool# :: Int# -> Prelude.Bool +bool# v = isTrue# v +{-# INLINE bool# #-} + +-- | A mkWeak# version that keep working on 8.0 +-- +-- signature change in ghc-prim: +-- * 0.4: mkWeak# :: o -> b -> c -> State# RealWorld -> (#State# RealWorld, Weak# b#) +-- * 0.5 :mkWeak# :: o -> b -> (State# RealWorld -> (#State# RealWorld, c#)) -> State# RealWorld -> (#State# RealWorld, Weak# b#) +-- +compatMkWeak# :: o -> b -> Prelude.IO () -> State# RealWorld -> (#State# RealWorld, Weak# b #) +compatMkWeak# o b c s = mkWeak# o b (case c of { IO f -> f }) s +{-# INLINE compatMkWeak# #-} + +#if __GLASGOW_HASKELL__ >= 802 +compatIsByteArrayPinned# :: ByteArray# -> Pinned# +compatIsByteArrayPinned# ba = isByteArrayPinned# ba + +compatIsMutableByteArrayPinned# :: MutableByteArray# s -> Pinned# +compatIsMutableByteArrayPinned# ba = isMutableByteArrayPinned# ba +#else +foreign import ccall unsafe "basement_is_bytearray_pinned" + compatIsByteArrayPinned# :: ByteArray# -> Pinned# + +foreign import ccall unsafe "basement_is_bytearray_pinned" + compatIsMutableByteArrayPinned# :: MutableByteArray# s -> Pinned# +#endif + +#if __GLASGOW_HASKELL__ >= 902 + +word8ToWord16# :: Word8# -> Word16# +word8ToWord16# a = wordToWord16# (word8ToWord# a) + +word8ToWord32# :: Word8# -> Word32# +word8ToWord32# a = wordToWord32# (word8ToWord# a) + +word16ToWord8# :: Word16# -> Word8# +word16ToWord8# a = wordToWord8# (word16ToWord# a) + +word16ToWord32# :: Word16# -> Word32# +word16ToWord32# a = wordToWord32# (word16ToWord# a) + +word32ToWord8# :: Word32# -> Word8# +word32ToWord8# a = wordToWord8# (word32ToWord# a) + +word32ToWord16# :: Word32# -> Word16# +word32ToWord16# a = wordToWord16# (word32ToWord# a) + +int8ToInt16# :: Int8# -> Int16# +int8ToInt16# i = intToInt16# (int8ToInt# i) + +int8ToInt32# :: Int8# -> Int32# +int8ToInt32# i = intToInt32# (int8ToInt# i) + +int16ToInt32# :: Int16# -> Int32# +int16ToInt32# i = intToInt32# (int16ToInt# i) + +word8ToInt16# :: Word8# -> Int16# +word8ToInt16# i = intToInt16# (word2Int# (word8ToWord# i)) + +word8ToInt32# :: Word8# -> Int32# +word8ToInt32# i = intToInt32# (word2Int# (word8ToWord# i)) + +word8ToInt# :: Word8# -> Int# +word8ToInt# i = word2Int# (word8ToWord# i) + +charToWord32# :: Char# -> Word32# +charToWord32# ch = wordToWord32# (int2Word# (ord# ch)) + +word8ToChar# :: Word8# -> Char# +word8ToChar# ch = chr# (word2Int# (word8ToWord# ch)) + +word16ToChar# :: Word16# -> Char# +word16ToChar# ch = chr# (word2Int# (word16ToWord# ch)) + +word32ToChar# :: Word32# -> Char# +word32ToChar# ch = chr# (word2Int# (word32ToWord# ch)) + +wordToChar# :: Word# -> Char# +wordToChar# ch = chr# (word2Int# ch) + +#else +type Word8# = Word# +type Word16# = Word# +type Word32# = Word# + +type Int8# = Int# +type Int16# = Int# +type Int32# = Int# + +word8ToWord16# :: Word8# -> Word16# +word8ToWord16# a = a + +word8ToWord32# :: Word8# -> Word32# +word8ToWord32# a = a + +word8ToWord# :: Word8# -> Word# +word8ToWord# a = a + +word16ToWord32# :: Word16# -> Word32# +word16ToWord32# a = a + +word16ToWord8# :: Word16# -> Word8# +word16ToWord8# w = narrow8Word# w + +word16ToWord# :: Word16# -> Word# +word16ToWord# a = a + +word32ToWord8# :: Word32# -> Word8# +word32ToWord8# w = narrow8Word# w + +word32ToWord16# :: Word32# -> Word16# +word32ToWord16# w = narrow16Word# w + +word32ToWord# :: Word32# -> Word# +word32ToWord# a = a + +wordToWord32# :: Word# -> Word32# +wordToWord32# w = narrow32Word# w + +wordToWord16# :: Word# -> Word16# +wordToWord16# w = narrow16Word# w + +wordToWord8# :: Word# -> Word8# +wordToWord8# w = narrow8Word# w + +charToWord32# :: Char# -> Word32# +charToWord32# ch = int2Word# (ord# ch) + +word8ToInt16# :: Word8# -> Int16# +word8ToInt16# w = word2Int# w + +word8ToInt32# :: Word8# -> Int32# +word8ToInt32# w = word2Int# w + +word8ToInt# :: Word8# -> Int# +word8ToInt# w = word2Int# w + +word8ToChar# :: Word8# -> Char# +word8ToChar# w = chr# (word2Int# w) + +word16ToChar# :: Word16# -> Char# +word16ToChar# w = chr# (word2Int# w) + +word32ToChar# :: Word32# -> Char# +word32ToChar# w = chr# (word2Int# w) + +wordToChar# :: Word# -> Char# +wordToChar# ch = chr# (word2Int# ch) + +int8ToInt16# :: Int8# -> Int16# +int8ToInt16# a = a + +int8ToInt32# :: Int8# -> Int32# +int8ToInt32# a = a + +int8ToInt# :: Int8# -> Int# +int8ToInt# a = a + +int16ToInt32# :: Int16# -> Int32# +int16ToInt32# a = a + +int16ToInt# :: Int16# -> Int# +int16ToInt# a = a + +int32ToInt# :: Int32# -> Int# +int32ToInt# a = a + +intToInt8# :: Int# -> Int8# +intToInt8# i = narrow8Int# i + +intToInt16# :: Int# -> Int16# +intToInt16# i = narrow16Int# i + +intToInt32# :: Int# -> Int32# +intToInt32# i = narrow32Int# i + +uncheckedShiftRLWord16# = uncheckedShiftRL# + +uncheckedShiftRLWord32# = uncheckedShiftRL# + +plusWord8# :: Word8# -> Word8# -> Word8# +plusWord8# a b = narrow8Word# (plusWord# a b) + +plusWord16# :: Word16# -> Word16# -> Word16# +plusWord16# a b = narrow16Word# (plusWord# a b) + +plusWord32# :: Word32# -> Word32# -> Word32# +plusWord32# a b = narrow32Word# (plusWord# a b) + +plusInt8# :: Int8# -> Int8# -> Int8# +plusInt8# a b = narrow8Int# (a +# b) + +plusInt16# :: Int16# -> Int16# -> Int16# +plusInt16# a b = narrow16Int# (a +# b) + +plusInt32# :: Int32# -> Int32# -> Int32# +plusInt32# a b = narrow32Int# (a +# b) + +#endif diff --git a/bundled/Basement/Compat/Semigroup.hs b/bundled/Basement/Compat/Semigroup.hs new file mode 100644 index 0000000..9ee59f3 --- /dev/null +++ b/bundled/Basement/Compat/Semigroup.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +#if !(MIN_VERSION_base(4,9,0)) +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +#endif +module Basement.Compat.Semigroup + ( Semigroup(..) + , ListNonEmpty(..) + ) where + +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup +import qualified Data.List.NonEmpty as LNE + +type ListNonEmpty = LNE.NonEmpty +#else +import Prelude +import Data.Data (Data) +import Data.Monoid (Monoid(..)) +import GHC.Generics (Generic) +import Data.Typeable + +-- errorWithoutStackTrace + +infixr 6 <> +infixr 5 :| + +data ListNonEmpty a = a :| [a] + deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic ) + +-- | The class of semigroups (types with an associative binary operation). +-- +-- @since 4.9.0.0 +class Semigroup a where + -- | An associative operation. + -- + -- @ + -- (a '<>' b) '<>' c = a '<>' (b '<>' c) + -- @ + -- + -- If @a@ is also a 'Monoid' we further require + -- + -- @ + -- ('<>') = 'mappend' + -- @ + (<>) :: a -> a -> a + + default (<>) :: Monoid a => a -> a -> a + (<>) = mappend + + -- | Reduce a non-empty list with @\<\>@ + -- + -- The default definition should be sufficient, but this can be + -- overridden for efficiency. + -- + sconcat :: ListNonEmpty a -> a + sconcat (a :| as) = go a as where + go b (c:cs) = b <> go c cs + go b [] = b + + -- | Repeat a value @n@ times. + -- + -- Given that this works on a 'Semigroup' it is allowed to fail if + -- you request 0 or fewer repetitions, and the default definition + -- will do so. + -- + -- By making this a member of the class, idempotent semigroups and monoids can + -- upgrade this to execute in /O(1)/ by picking + -- @stimes = stimesIdempotent@ or @stimes = stimesIdempotentMonoid@ + -- respectively. + stimes :: Integral b => b -> a -> a + stimes y0 x0 + | y0 <= 0 = errorWithoutStackTrace "stimes: positive multiplier expected" + | otherwise = f x0 y0 + where + f x y + | even y = f (x <> x) (y `quot` 2) + | y == 1 = x + | otherwise = g (x <> x) (pred y `quot` 2) x + g x y z + | even y = g (x <> x) (y `quot` 2) z + | y == 1 = x <> z + | otherwise = g (x <> x) (pred y `quot` 2) (x <> z) + +instance Semigroup a => Semigroup (Maybe a) where + Nothing <> b = b + a <> Nothing = a + Just a <> Just b = Just (a <> b) + stimes _ Nothing = Nothing + stimes n (Just a) = case compare n 0 of + LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier" + EQ -> Nothing + GT -> Just (stimes n a) + +instance Semigroup [a] where + (<>) = (++) + +instance Semigroup (Either a b) where + Left _ <> b = b + a <> _ = a + stimes = stimesIdempotent + +instance (Semigroup a, Semigroup b) => Semigroup (a, b) where + (a,b) <> (a',b') = (a<>a',b<>b') + stimes n (a,b) = (stimes n a, stimes n b) + +instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where + (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c') + stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c) + +instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d) + => Semigroup (a, b, c, d) where + (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d') + stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d) + +instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e) + => Semigroup (a, b, c, d, e) where + (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e') + stimes n (a,b,c,d,e) = + (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e) + +-- | This is a valid definition of 'stimes' for a 'Monoid'. +-- +-- Unlike the default definition of 'stimes', it is defined for 0 +-- and so it should be preferred where possible. +stimesMonoid :: (Integral b, Monoid a) => b -> a -> a +stimesMonoid n x0 = case compare n 0 of + LT -> errorWithoutStackTrace "stimesMonoid: negative multiplier" + EQ -> mempty + GT -> f x0 n + where + f x y + | even y = f (x `mappend` x) (y `quot` 2) + | y == 1 = x + | otherwise = g (x `mappend` x) (pred y `quot` 2) x + g x y z + | even y = g (x `mappend` x) (y `quot` 2) z + | y == 1 = x `mappend` z + | otherwise = g (x `mappend` x) (pred y `quot` 2) (x `mappend` z) + +-- | This is a valid definition of 'stimes' for an idempotent 'Monoid'. +-- +-- When @mappend x x = x@, this definition should be preferred, because it +-- works in /O(1)/ rather than /O(log n)/ +stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a +stimesIdempotentMonoid n x = case compare n 0 of + LT -> errorWithoutStackTrace "stimesIdempotentMonoid: negative multiplier" + EQ -> mempty + GT -> x + +-- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'. +-- +-- When @x <> x = x@, this definition should be preferred, because it +-- works in /O(1)/ rather than /O(log n)/. +stimesIdempotent :: Integral b => b -> a -> a +stimesIdempotent n x + | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected" + | otherwise = x + +#if !MIN_VERSION_base(4,9,0) +errorWithoutStackTrace = error +#endif + +#endif diff --git a/bundled/Basement/Compat/Typeable.hs b/bundled/Basement/Compat/Typeable.hs new file mode 100644 index 0000000..d7c5710 --- /dev/null +++ b/bundled/Basement/Compat/Typeable.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Compat.Typeable +-- License : BSD-style +-- Maintainer : Nicolas Di Prima +-- Stability : statble +-- Portability : portable +-- +-- conveniently provide support for legacy and modern base +-- + +{-# LANGUAGE CPP #-} + +module Basement.Compat.Typeable + ( +#if MIN_VERSION_base(4,7,0) + Typeable +#else + Typeable(..) + , typeRep +#endif + ) where + +#if !MIN_VERSION_base(4,7,0) +import Data.Proxy (Proxy(..)) +import qualified Prelude (undefined) +#endif +import Data.Typeable + +#if !MIN_VERSION_base(4,7,0) +-- this function does not exist prior base 4.7 +typeRep :: Typeable a => Proxy a -> TypeRep +typeRep = typeRep' Prelude.undefined + where + typeRep' :: Typeable a => a -> Proxy a -> TypeRep + typeRep' a _ = typeOf a + {-# INLINE typeRep' #-} +#endif diff --git a/bundled/Basement/Endianness.hs b/bundled/Basement/Endianness.hs new file mode 100644 index 0000000..bc5e8a2 --- /dev/null +++ b/bundled/Basement/Endianness.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Endianness +-- License : BSD-style +-- Maintainer : Haskell Foundation +-- Stability : experimental +-- Portability : portable +-- +-- Set endianness tag to a given primitive. This will help for serialising +-- data for protocols (such as the network protocols). +-- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Basement.Endianness + ( + ByteSwap + -- * Big Endian + , BE(..), toBE, fromBE + -- * Little Endian + , LE(..), toLE, fromLE + -- * System Endianness + , Endianness(..) + , endianness + ) where + +import Basement.Compat.Base +import Data.Word (byteSwap16, byteSwap32, byteSwap64) + +#if defined(ARCH_IS_LITTLE_ENDIAN) || defined(ARCH_IS_BIG_ENDIAN) +#else +import Foreign.Marshal.Alloc (alloca) +import Foreign.Ptr (castPtr) +import Foreign.Storable (poke, peek) +import Data.Word (Word8, Word32) +import System.IO.Unsafe (unsafePerformIO) +#endif + +import Data.Bits + + +-- #if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN) +-- import Foundation.System.Info (endianness, Endianness(..)) +-- #endif + +data Endianness = + LittleEndian + | BigEndian + deriving (Eq, Show) + +-- | Little Endian value +newtype LE a = LE { unLE :: a } + deriving (Show, Eq, Typeable, Bits) +instance (ByteSwap a, Ord a) => Ord (LE a) where + compare e1 e2 = compare (fromLE e1) (fromLE e2) + +-- | Big Endian value +newtype BE a = BE { unBE :: a } + deriving (Show, Eq, Typeable, Bits) +instance (ByteSwap a, Ord a) => Ord (BE a) where + compare e1 e2 = compare (fromBE e1) (fromBE e2) + +-- | Convert a value in cpu endianess to big endian +toBE :: ByteSwap a => a -> BE a +#ifdef ARCH_IS_LITTLE_ENDIAN +toBE = BE . byteSwap +#elif ARCH_IS_BIG_ENDIAN +toBE = BE +#else +toBE = BE . (if endianness == LittleEndian then byteSwap else id) +#endif +{-# INLINE toBE #-} + +-- | Convert from a big endian value to the cpu endianness +fromBE :: ByteSwap a => BE a -> a +#ifdef ARCH_IS_LITTLE_ENDIAN +fromBE (BE a) = byteSwap a +#elif ARCH_IS_BIG_ENDIAN +fromBE (BE a) = a +#else +fromBE (BE a) = if endianness == LittleEndian then byteSwap a else a +#endif +{-# INLINE fromBE #-} + +-- | Convert a value in cpu endianess to little endian +toLE :: ByteSwap a => a -> LE a +#ifdef ARCH_IS_LITTLE_ENDIAN +toLE = LE +#elif ARCH_IS_BIG_ENDIAN +toLE = LE . byteSwap +#else +toLE = LE . (if endianness == LittleEndian then id else byteSwap) +#endif +{-# INLINE toLE #-} + +-- | Convert from a little endian value to the cpu endianness +fromLE :: ByteSwap a => LE a -> a +#ifdef ARCH_IS_LITTLE_ENDIAN +fromLE (LE a) = a +#elif ARCH_IS_BIG_ENDIAN +fromLE (LE a) = byteSwap a +#else +fromLE (LE a) = if endianness == LittleEndian then a else byteSwap a +#endif +{-# INLINE fromLE #-} + +-- | endianness of the current architecture +endianness :: Endianness +#ifdef ARCH_IS_LITTLE_ENDIAN +endianness = LittleEndian +#elif ARCH_IS_BIG_ENDIAN +endianness = BigEndian +#else +-- ! ARCH_IS_UNKNOWN_ENDIAN +endianness = unsafePerformIO $ bytesToEndianness <$> word32ToByte input + where + input :: Word32 + input = 0x01020304 +{-# NOINLINE endianness #-} + +word32ToByte :: Word32 -> IO Word8 +word32ToByte word = alloca $ \wordPtr -> do + poke wordPtr word + peek (castPtr wordPtr) + +bytesToEndianness :: Word8 -> Endianness +bytesToEndianness 1 = BigEndian +bytesToEndianness _ = LittleEndian +#endif + +-- | Class of types that can be byte-swapped. +-- +-- e.g. Word16, Word32, Word64 +class ByteSwap a where + byteSwap :: a -> a +instance ByteSwap Word16 where + byteSwap = byteSwap16 +instance ByteSwap Word32 where + byteSwap = byteSwap32 +instance ByteSwap Word64 where + byteSwap = byteSwap64 diff --git a/bundled/Basement/Environment.hs b/bundled/Basement/Environment.hs new file mode 100644 index 0000000..1bdc945 --- /dev/null +++ b/bundled/Basement/Environment.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Basement.Environment + ( getArgs + , lookupEnv + ) where + +import Basement.Compat.Base +import Basement.UTF8.Base (String) +import qualified System.Environment as Sys (getArgs, lookupEnv) + +-- | Returns a list of the program's command line arguments (not including the program name). +getArgs :: IO [String] +getArgs = fmap fromList <$> Sys.getArgs + +-- | Lookup variable in the environment +lookupEnv :: String -> IO (Maybe String) +lookupEnv s = fmap fromList <$> Sys.lookupEnv (toList s) diff --git a/bundled/Basement/Error.hs b/bundled/Basement/Error.hs new file mode 100644 index 0000000..b9ec121 --- /dev/null +++ b/bundled/Basement/Error.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TypeInType #-} +#endif +module Basement.Error + ( error + ) where + +import GHC.Prim +import Basement.UTF8.Base +import Basement.Compat.CallStack + +#if MIN_VERSION_base(4,9,0) + +import GHC.Types (RuntimeRep) +import GHC.Exception (errorCallWithCallStackException) + +-- | stop execution and displays an error message +error :: forall (r :: RuntimeRep) . forall (a :: TYPE r) . HasCallStack => String -> a +error s = raise# (errorCallWithCallStackException (sToList s) ?callstack) + +#elif MIN_VERSION_base(4,7,0) + +import GHC.Exception (errorCallException) + +error :: String -> a +error s = raise# (errorCallException (sToList s)) + +#else + +import GHC.Types +import GHC.Exception + +error :: String -> a +error s = throw (ErrorCall (sToList s)) + +#endif diff --git a/bundled/Basement/Exception.hs b/bundled/Basement/Exception.hs new file mode 100644 index 0000000..4aaeb74 --- /dev/null +++ b/bundled/Basement/Exception.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Exception +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- Common part for vectors +-- +{-# LANGUAGE DeriveDataTypeable #-} +module Basement.Exception + ( OutOfBound(..) + , OutOfBoundOperation(..) + , isOutOfBound + , outOfBound + , primOutOfBound + , InvalidRecast(..) + , RecastSourceSize(..) + , RecastDestinationSize(..) + , NonEmptyCollectionIsEmpty(..) + ) where + +import Basement.Compat.Base +import Basement.Types.OffsetSize +import Basement.Monad + +-- | The type of operation that triggers an OutOfBound exception. +-- +-- * OOB_Index: reading an immutable vector +-- * OOB_Read: reading a mutable vector +-- * OOB_Write: write a mutable vector +-- * OOB_MemCopy: copying a vector +-- * OOB_MemSet: initializing a mutable vector +data OutOfBoundOperation = OOB_Read | OOB_Write | OOB_MemSet | OOB_MemCopy | OOB_Index + deriving (Show,Eq,Typeable) + +-- | Exception during an operation accessing the vector out of bound +-- +-- Represent the type of operation, the index accessed, and the total length of the vector. +data OutOfBound = OutOfBound OutOfBoundOperation Int Int + deriving (Show,Typeable) + +instance Exception OutOfBound + +outOfBound :: OutOfBoundOperation -> Offset ty -> CountOf ty -> a +outOfBound oobop (Offset ofs) (CountOf sz) = throw (OutOfBound oobop ofs sz) +{-# INLINE outOfBound #-} + +primOutOfBound :: PrimMonad prim => OutOfBoundOperation -> Offset ty -> CountOf ty -> prim a +primOutOfBound oobop (Offset ofs) (CountOf sz) = primThrow (OutOfBound oobop ofs sz) +{-# INLINE primOutOfBound #-} + +isOutOfBound :: Offset ty -> CountOf ty -> Bool +isOutOfBound (Offset ty) (CountOf sz) = ty < 0 || ty >= sz +{-# INLINE isOutOfBound #-} + +newtype RecastSourceSize = RecastSourceSize Int + deriving (Show,Eq,Typeable) +newtype RecastDestinationSize = RecastDestinationSize Int + deriving (Show,Eq,Typeable) + +data InvalidRecast = InvalidRecast RecastSourceSize RecastDestinationSize + deriving (Show,Typeable) + +instance Exception InvalidRecast + +-- | Exception for using NonEmpty assertion with an empty collection +data NonEmptyCollectionIsEmpty = NonEmptyCollectionIsEmpty + deriving (Show,Typeable) + +instance Exception NonEmptyCollectionIsEmpty diff --git a/bundled/Basement/FinalPtr.hs b/bundled/Basement/FinalPtr.hs new file mode 100644 index 0000000..a744332 --- /dev/null +++ b/bundled/Basement/FinalPtr.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.FinalPtr +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- A smaller ForeignPtr reimplementation that work in any prim monad. +-- +-- Here be dragon. +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE CPP #-} +module Basement.FinalPtr + ( FinalPtr(..) + , finalPtrSameMemory + , castFinalPtr + , toFinalPtr + , toFinalPtrForeign + , touchFinalPtr + , withFinalPtr + , withUnsafeFinalPtr + , withFinalPtrNoTouch + ) where + +import GHC.Ptr +import qualified GHC.ForeignPtr as GHCF +import GHC.IO +import Basement.Monad +import Basement.Compat.Primitive +import Basement.Compat.Base + +import Control.Monad.ST (runST) + +-- | Create a pointer with an associated finalizer +data FinalPtr a = FinalPtr (Ptr a) + | FinalForeign (GHCF.ForeignPtr a) +instance Show (FinalPtr a) where + show f = runST $ withFinalPtr f (pure . show) +instance Eq (FinalPtr a) where + (==) f1 f2 = runST (equal f1 f2) +instance Ord (FinalPtr a) where + compare f1 f2 = runST (compare_ f1 f2) + +-- | Check if 2 final ptr points on the same memory bits +-- +-- it stand to reason that provided a final ptr that is still being referenced +-- and thus have the memory still valid, if 2 final ptrs have the +-- same address, they should be the same final ptr +finalPtrSameMemory :: FinalPtr a -> FinalPtr b -> Bool +finalPtrSameMemory (FinalPtr p1) (FinalPtr p2) = p1 == castPtr p2 +finalPtrSameMemory (FinalForeign p1) (FinalForeign p2) = p1 == GHCF.castForeignPtr p2 +finalPtrSameMemory (FinalForeign _) (FinalPtr _) = False +finalPtrSameMemory (FinalPtr _) (FinalForeign _) = False + +-- | create a new FinalPtr from a Pointer +toFinalPtr :: PrimMonad prim => Ptr a -> (Ptr a -> IO ()) -> prim (FinalPtr a) +toFinalPtr ptr finalizer = unsafePrimFromIO (primitive makeWithFinalizer) + where + makeWithFinalizer s = + case compatMkWeak# ptr () (finalizer ptr) s of { (# s2, _ #) -> (# s2, FinalPtr ptr #) } + +-- | Create a new FinalPtr from a ForeignPtr +toFinalPtrForeign :: GHCF.ForeignPtr a -> FinalPtr a +toFinalPtrForeign fptr = FinalForeign fptr + +-- | Cast a finalized pointer from type a to type b +castFinalPtr :: FinalPtr a -> FinalPtr b +castFinalPtr (FinalPtr a) = FinalPtr (castPtr a) +castFinalPtr (FinalForeign a) = FinalForeign (GHCF.castForeignPtr a) + +withFinalPtrNoTouch :: FinalPtr p -> (Ptr p -> a) -> a +withFinalPtrNoTouch (FinalPtr ptr) f = f ptr +withFinalPtrNoTouch (FinalForeign fptr) f = f (GHCF.unsafeForeignPtrToPtr fptr) +{-# INLINE withFinalPtrNoTouch #-} + +-- | Looks at the raw pointer inside a FinalPtr, making sure the +-- data pointed by the pointer is not finalized during the call to 'f' +withFinalPtr :: PrimMonad prim => FinalPtr p -> (Ptr p -> prim a) -> prim a +withFinalPtr (FinalPtr ptr) f = do + r <- f ptr + primTouch ptr + pure r +withFinalPtr (FinalForeign fptr) f = do + r <- f (GHCF.unsafeForeignPtrToPtr fptr) + unsafePrimFromIO (GHCF.touchForeignPtr fptr) + pure r +{-# INLINE withFinalPtr #-} + +touchFinalPtr :: PrimMonad prim => FinalPtr p -> prim () +touchFinalPtr (FinalPtr ptr) = primTouch ptr +touchFinalPtr (FinalForeign fptr) = unsafePrimFromIO (GHCF.touchForeignPtr fptr) + +-- | Unsafe version of 'withFinalPtr' +withUnsafeFinalPtr :: PrimMonad prim => FinalPtr p -> (Ptr p -> prim a) -> a +withUnsafeFinalPtr fptr f = unsafePerformIO (unsafePrimToIO (withFinalPtr fptr f)) +{-# NOINLINE withUnsafeFinalPtr #-} + +equal :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Bool +equal f1 f2 = + withFinalPtr f1 $ \ptr1 -> + withFinalPtr f2 $ \ptr2 -> + pure $ ptr1 == ptr2 +{-# INLINE equal #-} + +compare_ :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Ordering +compare_ f1 f2 = + withFinalPtr f1 $ \ptr1 -> + withFinalPtr f2 $ \ptr2 -> + pure $ ptr1 `compare` ptr2 +{-# INLINE compare_ #-} diff --git a/bundled/Basement/Floating.hs b/bundled/Basement/Floating.hs new file mode 100644 index 0000000..0664cfe --- /dev/null +++ b/bundled/Basement/Floating.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +module Basement.Floating + ( integerToDouble + , naturalToDouble + , doubleExponant + , integerToFloat + , naturalToFloat + , wordToFloat + , floatToWord + , wordToDouble + , doubleToWord + ) where + +import GHC.Types +import GHC.Prim +import GHC.Float +import GHC.Word +import GHC.ST +import Basement.Compat.Base +import Basement.Compat.Natural +import qualified Prelude (fromInteger, toInteger, (^^)) + +integerToDouble :: Integer -> Double +integerToDouble = Prelude.fromInteger +-- this depends on integer-gmp +--integerToDouble i = D# (doubleFromInteger i) + +naturalToDouble :: Natural -> Double +naturalToDouble = integerToDouble . Prelude.toInteger + +doubleExponant :: Double -> Int -> Double +doubleExponant = (Prelude.^^) + +integerToFloat :: Integer -> Float +integerToFloat = Prelude.fromInteger + +naturalToFloat :: Natural -> Float +naturalToFloat = integerToFloat . Prelude.toInteger + +wordToFloat :: Word32 -> Float +wordToFloat (W32# x) = runST $ ST $ \s1 -> + case newByteArray# 4# s1 of { (# s2, mbarr #) -> + case writeWord32Array# mbarr 0# x s2 of { s3 -> + case readFloatArray# mbarr 0# s3 of { (# s4, f #) -> + (# s4, F# f #) }}} +{-# INLINE wordToFloat #-} + +floatToWord :: Float -> Word32 +floatToWord (F# x) = runST $ ST $ \s1 -> + case newByteArray# 4# s1 of { (# s2, mbarr #) -> + case writeFloatArray# mbarr 0# x s2 of { s3 -> + case readWord32Array# mbarr 0# s3 of { (# s4, w #) -> + (# s4, W32# w #) }}} +{-# INLINE floatToWord #-} + +wordToDouble :: Word64 -> Double +wordToDouble (W64# x) = runST $ ST $ \s1 -> + case newByteArray# 8# s1 of { (# s2, mbarr #) -> + case writeWord64Array# mbarr 0# x s2 of { s3 -> + case readDoubleArray# mbarr 0# s3 of { (# s4, f #) -> + (# s4, D# f #) }}} +{-# INLINE wordToDouble #-} + +doubleToWord :: Double -> Word64 +doubleToWord (D# x) = runST $ ST $ \s1 -> + case newByteArray# 8# s1 of { (# s2, mbarr #) -> + case writeDoubleArray# mbarr 0# x s2 of { s3 -> + case readWord64Array# mbarr 0# s3 of { (# s4, w #) -> + (# s4, W64# w #) }}} +{-# INLINE doubleToWord #-} diff --git a/bundled/Basement/From.hs b/bundled/Basement/From.hs new file mode 100644 index 0000000..daac000 --- /dev/null +++ b/bundled/Basement/From.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Basement.From +-- License : BSD-style +-- Maintainer : Haskell Foundation +-- +-- Flexible Type convertion +-- +-- From is multi parameter type class that allow converting +-- from a to b. +-- +-- Only type that are valid to convert to another type +-- should be From instance; otherwise TryFrom should be used. +-- +-- Into (resp TryInto) allows the contrary instances to be able +-- to specify the destination type before the source. This is +-- practical with TypeApplication +module Basement.From + ( From(..) + , Into + , TryFrom(..) + , TryInto + , into + , tryInto + ) where + +import Basement.Compat.Base + +-- basic instances +import GHC.Types +import GHC.Prim hiding (word64ToWord#) +import qualified GHC.Prim +import GHC.Int +import GHC.Word +import Basement.Numerical.Number +import Basement.Numerical.Conversion +import qualified Basement.Block as Block +import qualified Basement.BoxedArray as BoxArray +import Basement.Cast (cast) +import qualified Basement.UArray as UArray +import qualified Basement.String as String +import qualified Basement.Types.AsciiString as AsciiString +import Basement.Types.Word128 (Word128(..)) +import Basement.Types.Word256 (Word256(..)) +import qualified Basement.Types.Word128 as Word128 +import qualified Basement.Types.Word256 as Word256 +import Basement.These +import Basement.PrimType (PrimType, PrimSize) +import Basement.Types.OffsetSize +import Basement.Compat.Natural +import Basement.Compat.Primitive +import qualified Prelude (fromIntegral) + +-- nat instances +#if __GLASGOW_HASKELL__ >= 800 +import Basement.Nat +import qualified Basement.Sized.Block as BlockN +import Basement.Bounded +#endif + +-- | Class of things that can be converted from a to b. +-- +-- In a valid instance, the source should be always representable by the destination, +-- otherwise the instance should be using 'TryFrom' +class From a b where + from :: a -> b + +type Into b a = From a b + +-- | Same as from but reverse the type variable so that the destination type can be specified first +-- +-- e.g. converting: +-- +-- from @_ @Word (10 :: Int) +-- +-- into @Word (10 :: Int) +-- +into :: Into b a => a -> b +into = from + +-- | Class of things that can mostly be converted from a to b, but with possible error cases. +class TryFrom a b where + tryFrom :: a -> Maybe b + +type TryInto b a = TryFrom a b + +-- | same as tryFrom but reversed +tryInto :: TryInto b a => a -> Maybe b +tryInto = tryFrom + +instance From a a where + from = id + +instance IsNatural n => From n Natural where + from = toNatural +instance IsIntegral n => From n Integer where + from = toInteger + +instance From Int8 Int16 where + from (I8# i) = I16# (int8ToInt16# i) +instance From Int8 Int32 where + from (I8# i) = I32# (int8ToInt32# i) +instance From Int8 Int64 where + from (I8# i) = intToInt64 (I# (int8ToInt# i)) +instance From Int8 Int where + from (I8# i) = I# (int8ToInt# i) + +instance From Int16 Int32 where + from (I16# i) = I32# (int16ToInt32# i) +instance From Int16 Int64 where + from (I16# i) = intToInt64 (I# (int16ToInt# i)) +instance From Int16 Int where + from (I16# i) = I# (int16ToInt# i) + +instance From Int32 Int64 where + from (I32# i) = intToInt64 (I# (int32ToInt# i)) +instance From Int32 Int where + from (I32# i) = I# (int32ToInt# i) + +instance From Int Int64 where + from = intToInt64 + +instance From Word8 Word16 where + from (W8# i) = W16# (word8ToWord16# i) +instance From Word8 Word32 where + from (W8# i) = W32# (word8ToWord32# i) +instance From Word8 Word64 where + from (W8# i) = wordToWord64 (W# (word8ToWord# i)) +instance From Word8 Word128 where + from (W8# i) = Word128 0 (wordToWord64 $ W# (word8ToWord# i)) +instance From Word8 Word256 where + from (W8# i) = Word256 0 0 0 (wordToWord64 $ W# (word8ToWord# i)) +instance From Word8 Word where + from (W8# i) = W# (word8ToWord# i) +instance From Word8 Int16 where + from (W8# w) = I16# (intToInt16# (word2Int# (word8ToWord# w))) +instance From Word8 Int32 where + from (W8# w) = I32# (intToInt32# (word2Int# (word8ToWord# w))) +instance From Word8 Int64 where + from (W8# w) = intToInt64 (I# (word2Int# (word8ToWord# w))) +instance From Word8 Int where + from (W8# w) = I# (word2Int# (word8ToWord# w)) + +instance From Word16 Word32 where + from (W16# i) = W32# (word16ToWord32# i) +instance From Word16 Word64 where + from (W16# i) = wordToWord64 (W# (word16ToWord# i)) +instance From Word16 Word128 where + from (W16# i) = Word128 0 (wordToWord64 $ W# (word16ToWord# i)) +instance From Word16 Word256 where + from (W16# i) = Word256 0 0 0 (wordToWord64 $ W# (word16ToWord# i)) +instance From Word16 Word where + from (W16# i) = W# (word16ToWord# i) +instance From Word16 Int32 where + from (W16# w) = I32# (intToInt32# (word2Int# (word16ToWord# w))) +instance From Word16 Int64 where + from (W16# w) = intToInt64 (I# (word2Int# (word16ToWord# w))) +instance From Word16 Int where + from (W16# w) = I# (word2Int# (word16ToWord# w)) + +instance From Word32 Word64 where + from (W32# i) = wordToWord64 (W# (word32ToWord# i)) +instance From Word32 Word128 where + from (W32# i) = Word128 0 (wordToWord64 $ W# (word32ToWord# i)) +instance From Word32 Word256 where + from (W32# i) = Word256 0 0 0 (wordToWord64 $ W# (word32ToWord# i)) +instance From Word32 Word where + from (W32# i) = W# (word32ToWord# i) +instance From Word32 Int64 where + from (W32# w) = intToInt64 (I# (word2Int# (word32ToWord# w))) +instance From Word32 Int where + from (W32# w) = I# (word2Int# (word32ToWord# w)) + +instance From Word64 Word128 where + from w = Word128 0 w +instance From Word64 Word256 where + from w = Word256 0 0 0 w + +instance From Word Word64 where + from = wordToWord64 + +-- Simple prelude types +instance From (Maybe a) (Either () a) where + from (Just x) = Right x + from Nothing = Left () + +-- basic basement types +instance From (CountOf ty) Int where + from (CountOf n) = n +instance From (CountOf ty) Word where + -- here it is ok to cast the underlying `Int` held by `CountOf` to a `Word` + -- as the `Int` should never hold a negative value. + from (CountOf n) = cast n +instance From Word (Offset ty) where + from w = Offset (cast w) +instance TryFrom Int (Offset ty) where + tryFrom i + | i < 0 = Nothing + | otherwise = Just (Offset i) +instance TryFrom Int (CountOf ty) where + tryFrom i + | i < 0 = Nothing + | otherwise = Just (CountOf i) +instance From Word (CountOf ty) where + from w = CountOf (cast w) + +instance From (Either a b) (These a b) where + from (Left a) = This a + from (Right b) = That b + +instance From Word128 Word256 where + from (Word128 a b) = Word256 0 0 a b + +-- basement instances + +-- uarrays +instance PrimType ty => From (Block.Block ty) (UArray.UArray ty) where + from = UArray.fromBlock +instance PrimType ty => From (BoxArray.Array ty) (UArray.UArray ty) where + from = BoxArray.mapToUnboxed id + +-- blocks +instance PrimType ty => From (UArray.UArray ty) (Block.Block ty) where + from = UArray.toBlock +instance PrimType ty => From (BoxArray.Array ty) (Block.Block ty) where + from = UArray.toBlock . BoxArray.mapToUnboxed id + +-- boxed array +instance PrimType ty => From (UArray.UArray ty) (BoxArray.Array ty) where + from = BoxArray.mapFromUnboxed id + + +instance From String.String (UArray.UArray Word8) where + from = String.toBytes String.UTF8 + +instance From AsciiString.AsciiString String.String where + from = String.fromBytesUnsafe . UArray.unsafeRecast . AsciiString.toBytes +instance From AsciiString.AsciiString (UArray.UArray Word8) where + from = UArray.unsafeRecast . AsciiString.toBytes + +instance TryFrom (UArray.UArray Word8) String.String where + tryFrom arr = case String.fromBytes String.UTF8 arr of + (s, Nothing, _) -> Just s + (_, Just _, _) -> Nothing + +#if __GLASGOW_HASKELL__ >= 800 +instance From (BlockN.BlockN n ty) (Block.Block ty) where + from = BlockN.toBlock +instance (PrimType a, PrimType b, KnownNat n, KnownNat m, ((PrimSize b) Basement.Nat.* m) ~ ((PrimSize a) Basement.Nat.* n)) + => From (BlockN.BlockN n a) (BlockN.BlockN m b) where + from = BlockN.cast +instance (NatWithinBound Int n, PrimType ty) => From (BlockN.BlockN n ty) (UArray.UArray ty) where + from = UArray.fromBlock . BlockN.toBlock +instance (NatWithinBound Int n, PrimType ty) => From (BlockN.BlockN n ty) (BoxArray.Array ty) where + from = BoxArray.mapFromUnboxed id . UArray.fromBlock . BlockN.toBlock + +instance (NatWithinBound (CountOf ty) n, KnownNat n, PrimType ty) + => TryFrom (Block.Block ty) (BlockN.BlockN n ty) where + tryFrom = BlockN.toBlockN +instance (NatWithinBound (CountOf ty) n, KnownNat n, PrimType ty) + => TryFrom (UArray.UArray ty) (BlockN.BlockN n ty) where + tryFrom = BlockN.toBlockN . UArray.toBlock +instance (NatWithinBound (CountOf ty) n, KnownNat n, PrimType ty) + => TryFrom (BoxArray.Array ty) (BlockN.BlockN n ty) where + tryFrom = BlockN.toBlockN . UArray.toBlock . BoxArray.mapToUnboxed id + +instance (KnownNat n, NatWithinBound Word8 n) => From (Zn64 n) Word8 where +#if __GLASGOW_HASKELL__ >= 904 + from = narrow . unZn64 where narrow (W64# w) = W8# (wordToWord8# (word64ToWord# (GHC.Prim.word64ToWord# w))) +#else + from = narrow . unZn64 where narrow (W64# w) = W8# (wordToWord8# (word64ToWord# w)) +#endif +instance (KnownNat n, NatWithinBound Word16 n) => From (Zn64 n) Word16 where +#if __GLASGOW_HASKELL__ >= 904 + from = narrow . unZn64 where narrow (W64# w) = W16# (wordToWord16# (word64ToWord# (GHC.Prim.word64ToWord# w))) +#else + from = narrow . unZn64 where narrow (W64# w) = W16# (wordToWord16# (word64ToWord# w)) +#endif +instance (KnownNat n, NatWithinBound Word32 n) => From (Zn64 n) Word32 where +#if __GLASGOW_HASKELL__ >= 904 + from = narrow . unZn64 where narrow (W64# w) = W32# (wordToWord32# (word64ToWord# (GHC.Prim.word64ToWord# w))) +#else + from = narrow . unZn64 where narrow (W64# w) = W32# (wordToWord32# (word64ToWord# w)) +#endif +instance From (Zn64 n) Word64 where + from = unZn64 +instance From (Zn64 n) Word128 where + from = from . unZn64 +instance From (Zn64 n) Word256 where + from = from . unZn64 + +instance (KnownNat n, NatWithinBound Word8 n) => From (Zn n) Word8 where +#if __GLASGOW_HASKELL__ >= 904 + from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W8# (wordToWord8# (word64ToWord# (GHC.Prim.word64ToWord# w))) +#else + from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W8# (wordToWord8# (word64ToWord# w)) +#endif +instance (KnownNat n, NatWithinBound Word16 n) => From (Zn n) Word16 where +#if __GLASGOW_HASKELL__ >= 904 + from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W16# (wordToWord16# (word64ToWord# (GHC.Prim.word64ToWord# w))) +#else + from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W16# (wordToWord16# (word64ToWord# w)) +#endif +instance (KnownNat n, NatWithinBound Word32 n) => From (Zn n) Word32 where +#if __GLASGOW_HASKELL__ >= 904 + from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W32# (wordToWord32# (word64ToWord# (GHC.Prim.word64ToWord# w))) +#else + from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W32# (wordToWord32# (word64ToWord# w)) +#endif +instance (KnownNat n, NatWithinBound Word64 n) => From (Zn n) Word64 where + from = naturalToWord64 . unZn +instance (KnownNat n, NatWithinBound Word128 n) => From (Zn n) Word128 where + from = Word128.fromNatural . unZn +instance (KnownNat n, NatWithinBound Word256 n) => From (Zn n) Word256 where + from = Word256.fromNatural . unZn + +instance (KnownNat n, NatWithinBound Word64 n) => From (Zn n) (Zn64 n) where + from = zn64 . naturalToWord64 . unZn +instance KnownNat n => From (Zn64 n) (Zn n) where + from = zn . from . unZn64 + +naturalToWord64 :: Natural -> Word64 +naturalToWord64 = Prelude.fromIntegral +#endif diff --git a/bundled/Basement/Imports.hs b/bundled/Basement/Imports.hs new file mode 100644 index 0000000..52bfb03 --- /dev/null +++ b/bundled/Basement/Imports.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Imports +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- re-export of all the base prelude and basic primitive stuffs +{-# LANGUAGE CPP #-} +module Basement.Imports + ( (Prelude.$) + , (Prelude.$!) + , (Prelude.&&) + , (Prelude.||) + , (Control.Category..) + , (Control.Applicative.<$>) + , Prelude.not + , Prelude.otherwise + , Prelude.fst + , Prelude.snd + , Control.Category.id + , Prelude.maybe + , Prelude.either + , Prelude.flip + , Prelude.const + , Basement.Error.error + , Prelude.and + , Prelude.undefined + , Prelude.seq + , Prelude.Show + , Basement.Show.show + , Prelude.Ord (..) + , Prelude.Eq (..) + , Prelude.Bounded (..) + , Prelude.Enum (..) + , Prelude.Functor (..) + , Control.Applicative.Applicative (..) + , Prelude.Monad (..) + , Control.Monad.when + , Control.Monad.unless + , Prelude.Maybe (..) + , Prelude.Ordering (..) + , Prelude.Bool (..) + , Prelude.Int + , Prelude.Integer + , Basement.Compat.Natural.Natural + , Basement.Types.OffsetSize.Offset + , Basement.Types.OffsetSize.CountOf + , Prelude.Char + , Basement.PrimType.PrimType + , Basement.Types.Char7.Char7 + , Basement.Types.AsciiString.AsciiString + , Basement.UTF8.Base.String + , Basement.UArray.UArray + , Basement.BoxedArray.Array + , Basement.Compat.NumLiteral.Integral (..) + , Basement.Compat.NumLiteral.Fractional (..) + , Basement.Compat.NumLiteral.HasNegation (..) + , Data.Int.Int8, Data.Int.Int16, Data.Int.Int32, Data.Int.Int64 + , Data.Word.Word8, Data.Word.Word16, Data.Word.Word32, Data.Word.Word64, Data.Word.Word + , Prelude.Double, Prelude.Float + , Prelude.IO + , FP32 + , FP64 + , Basement.Compat.IsList.IsList (..) + , GHC.Exts.IsString (..) + , GHC.Generics.Generic (..) + , Prelude.Either (..) + , Data.Data.Data (..) + , Data.Data.mkNoRepType + , Data.Data.DataType + , Data.Typeable.Typeable + , Data.Monoid.Monoid (..) +#if MIN_VERSION_base(4,10,0) + -- , (Basement.Compat.Semigroup.<>) + , Basement.Compat.Semigroup.Semigroup(..) +#else + , (Data.Monoid.<>) + , Basement.Compat.Semigroup.Semigroup +#endif + , Control.Exception.Exception + , Control.Exception.throw + , Control.Exception.throwIO + , GHC.Ptr.Ptr(..) + , ifThenElse + ) where + +import qualified Prelude +import qualified Control.Category +import qualified Control.Applicative +import qualified Control.Exception +import qualified Control.Monad +import qualified Data.Monoid +import qualified Data.Data +import qualified Data.Typeable +import qualified Data.Word +import qualified Data.Int +import qualified Basement.Compat.IsList +import qualified Basement.Compat.Natural +import qualified Basement.Compat.NumLiteral +import qualified Basement.Compat.Semigroup +import qualified Basement.UArray +import qualified Basement.BoxedArray +import qualified Basement.UTF8.Base +import qualified Basement.Error +import qualified Basement.Show +import qualified Basement.PrimType +import qualified Basement.Types.OffsetSize +import qualified Basement.Types.AsciiString +import qualified Basement.Types.Char7 +import qualified GHC.Exts +import qualified GHC.Generics +import qualified GHC.Ptr +import GHC.Exts (fromString) + +-- | for support of if .. then .. else +ifThenElse :: Prelude.Bool -> a -> a -> a +ifThenElse Prelude.True e1 _ = e1 +ifThenElse Prelude.False _ e2 = e2 + +-- | IEEE754 Floating point Binary32, simple precision (Also known as Float) +type FP32 = Prelude.Float + +-- | IEEE754 Floating point Binary64, double precision (Also known as Double) +type FP64 = Prelude.Double diff --git a/bundled/Basement/IntegralConv.hs b/bundled/Basement/IntegralConv.hs new file mode 100644 index 0000000..a1c2ce7 --- /dev/null +++ b/bundled/Basement/IntegralConv.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +module Basement.IntegralConv + ( IntegralDownsize(..) + , IntegralUpsize(..) + , intToInt64 + , int64ToInt + , wordToWord64 + , word64ToWord32s + , Word32x2(..) + , word64ToWord + , wordToChar + , wordToInt + , charToInt + ) where + +import GHC.Types +import GHC.Prim hiding (word64ToWord#) +import qualified GHC.Prim +import GHC.Int +import GHC.Word +import Prelude (Integer, fromIntegral) +import Basement.Compat.Base +import Basement.Compat.Natural +import Basement.Compat.Primitive +import Basement.Numerical.Number +import Basement.Numerical.Conversion + +-- | Downsize an integral value +class IntegralDownsize a b where + integralDownsize :: a -> b + default integralDownsize :: a ~ b => a -> b + integralDownsize = id + + integralDownsizeCheck :: a -> Maybe b + +-- | Upsize an integral value +-- +-- The destination type 'b' size need to be greater or equal +-- than the size type of 'a' +class IntegralUpsize a b where + integralUpsize :: a -> b + +integralDownsizeBounded :: forall a b . (Ord a, Bounded b, IntegralDownsize a b, IntegralUpsize b a) + => (a -> b) + -> a + -> Maybe b +integralDownsizeBounded aToB x + | x < integralUpsize (minBound :: b) && x > integralUpsize (maxBound :: b) = Nothing + | otherwise = Just (aToB x) + +instance IsIntegral a => IntegralUpsize a Integer where + integralUpsize = toInteger +instance IsNatural a => IntegralUpsize a Natural where + integralUpsize = toNatural + +instance IntegralUpsize Int8 Int16 where + integralUpsize (I8# i) = I16# (int8ToInt16# i) +instance IntegralUpsize Int8 Int32 where + integralUpsize (I8# i) = I32# (int8ToInt32# i) +instance IntegralUpsize Int8 Int64 where + integralUpsize (I8# i) = intToInt64 (I# (int8ToInt# i)) +instance IntegralUpsize Int8 Int where + integralUpsize (I8# i) = I# (int8ToInt# i) + +instance IntegralUpsize Int16 Int32 where + integralUpsize (I16# i) = I32# (int16ToInt32# i) +instance IntegralUpsize Int16 Int64 where + integralUpsize (I16# i) = intToInt64 (I# (int16ToInt# i)) +instance IntegralUpsize Int16 Int where + integralUpsize (I16# i) = I# (int16ToInt# i) + +instance IntegralUpsize Int32 Int64 where + integralUpsize (I32# i) = intToInt64 (I# (int32ToInt# i)) +instance IntegralUpsize Int32 Int where + integralUpsize (I32# i) = I# (int32ToInt# i) + +instance IntegralUpsize Int Int64 where + integralUpsize = intToInt64 + +instance IntegralUpsize Word8 Word16 where + integralUpsize (W8# i) = W16# (word8ToWord16# i) +instance IntegralUpsize Word8 Word32 where + integralUpsize (W8# i) = W32# (word8ToWord32# i) +instance IntegralUpsize Word8 Word64 where + integralUpsize (W8# i) = wordToWord64 (W# (word8ToWord# i)) +instance IntegralUpsize Word8 Word where + integralUpsize (W8# i) = W# (word8ToWord# i) +instance IntegralUpsize Word8 Int16 where + integralUpsize (W8# w) = I16# (word8ToInt16# w) +instance IntegralUpsize Word8 Int32 where + integralUpsize (W8# w) = I32# (word8ToInt32# w) +instance IntegralUpsize Word8 Int64 where + integralUpsize (W8# w) = intToInt64 (I# (word2Int# (word8ToWord# w))) +instance IntegralUpsize Word8 Int where + integralUpsize (W8# w) = I# (word2Int# (word8ToWord# w)) + +instance IntegralUpsize Word16 Word32 where + integralUpsize (W16# i) = W32# (word16ToWord32# i) +instance IntegralUpsize Word16 Word64 where + integralUpsize (W16# i) = wordToWord64 (W# (word16ToWord# i)) +instance IntegralUpsize Word16 Word where + integralUpsize (W16# i) = W# (word16ToWord# i) + +instance IntegralUpsize Word32 Word64 where + integralUpsize (W32# i) = wordToWord64 (W# (word32ToWord# i)) +instance IntegralUpsize Word32 Word where + integralUpsize (W32# i) = W# (word32ToWord# i) + +instance IntegralUpsize Word Word64 where + integralUpsize = wordToWord64 + +instance IntegralDownsize Int Int8 where + integralDownsize (I# i) = I8# (intToInt8# i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Int Int16 where + integralDownsize (I# i) = I16# (intToInt16# i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Int Int32 where + integralDownsize (I# i) = I32# (intToInt32# i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize + +instance IntegralDownsize Int64 Int8 where + integralDownsize i = integralDownsize (int64ToInt i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Int64 Int16 where + integralDownsize i = integralDownsize (int64ToInt i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Int64 Int32 where + integralDownsize i = integralDownsize (int64ToInt i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Int64 Int where + integralDownsize i = int64ToInt i + integralDownsizeCheck = integralDownsizeBounded integralDownsize + +instance IntegralDownsize Word64 Word8 where +#if __GLASGOW_HASKELL__ >= 904 + integralDownsize (W64# i) = W8# (wordToWord8# (GHC.Prim.word64ToWord# i)) +#else + integralDownsize (W64# i) = W8# (wordToWord8# (word64ToWord# i)) +#endif + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Word64 Word16 where +#if __GLASGOW_HASKELL__ >= 904 + integralDownsize (W64# i) = W16# (wordToWord16# (GHC.Prim.word64ToWord# i)) +#else + integralDownsize (W64# i) = W16# (wordToWord16# (word64ToWord# i)) +#endif + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Word64 Word32 where +#if __GLASGOW_HASKELL__ >= 904 + integralDownsize (W64# i) = W32# (wordToWord32# (GHC.Prim.word64ToWord# i)) +#else + integralDownsize (W64# i) = W32# (wordToWord32# (word64ToWord# i)) +#endif + integralDownsizeCheck = integralDownsizeBounded integralDownsize + +instance IntegralDownsize Word Word8 where + integralDownsize (W# w) = W8# (wordToWord8# w) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Word Word16 where + integralDownsize (W# w) = W16# (wordToWord16# w) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Word Word32 where + integralDownsize (W# w) = W32# (wordToWord32# w) + integralDownsizeCheck = integralDownsizeBounded integralDownsize + +instance IntegralDownsize Word32 Word8 where + integralDownsize (W32# i) = W8# (word32ToWord8# i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Word32 Word16 where + integralDownsize (W32# i) = W16# (word32ToWord16# i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize + +instance IntegralDownsize Word16 Word8 where + integralDownsize (W16# i) = W8# (word16ToWord8# i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize + +instance IntegralDownsize Integer Int8 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Integer Int16 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Integer Int32 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Integer Int64 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize + +instance IntegralDownsize Integer Word8 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Integer Word16 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Integer Word32 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Integer Word64 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Integer Natural where + integralDownsize i + | i >= 0 = fromIntegral i + | otherwise = 0 + integralDownsizeCheck i + | i >= 0 = Just (fromIntegral i) + | otherwise = Nothing + +instance IntegralDownsize Natural Word8 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Natural Word16 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Natural Word32 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Natural Word64 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize diff --git a/bundled/Basement/Monad.hs b/bundled/Basement/Monad.hs new file mode 100644 index 0000000..7735743 --- /dev/null +++ b/bundled/Basement/Monad.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Monad +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- Allow to run operation in ST and IO, without having to +-- distinguinsh between the two. Most operations exposes +-- the bare nuts and bolts of how IO and ST actually +-- works, and relatively easy to shoot yourself in the foot +-- +-- this is highly similar to the Control.Monad.Primitive +-- in the primitive package +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +module Basement.Monad + ( PrimMonad(..) + , MonadFailure(..) + , unPrimMonad_ + , unsafePrimCast + , unsafePrimToST + , unsafePrimToIO + , unsafePrimFromIO + , primTouch + ) where + +import qualified Prelude +import GHC.ST +import GHC.STRef +import GHC.IORef +import GHC.IO +import GHC.Prim +import Basement.Compat.Base (Exception, (.), ($), Applicative, Monad) +import Basement.Compat.Primitive + +-- | Primitive monad that can handle mutation. +-- +-- For example: IO and ST. +class (Prelude.Functor m, Applicative m, Prelude.Monad m) => PrimMonad m where + -- | type of state token associated with the PrimMonad m + type PrimState m + -- | type of variable associated with the PrimMonad m + type PrimVar m :: * -> * + -- | Unwrap the State# token to pass to a function a primitive function that returns an unboxed state and a value. + primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a + -- | Throw Exception in the primitive monad + primThrow :: Exception e => e -> m a + -- | Run a Prim monad from a dedicated state# + unPrimMonad :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #) + + -- | Build a new variable in the Prim Monad + primVarNew :: a -> m (PrimVar m a) + -- | Read the variable in the Prim Monad + primVarRead :: PrimVar m a -> m a + -- | Write the variable in the Prim Monad + primVarWrite :: PrimVar m a -> a -> m () + +-- | just like `unwrapPrimMonad` but throw away the result and return just the new State# +unPrimMonad_ :: PrimMonad m => m () -> State# (PrimState m) -> State# (PrimState m) +unPrimMonad_ p st = + case unPrimMonad p st of + (# st', () #) -> st' +{-# INLINE unPrimMonad_ #-} + +instance PrimMonad IO where + type PrimState IO = RealWorld + type PrimVar IO = IORef + primitive = IO + {-# INLINE primitive #-} + primThrow = throwIO + unPrimMonad (IO p) = p + {-# INLINE unPrimMonad #-} + primVarNew = newIORef + primVarRead = readIORef + primVarWrite = writeIORef + +instance PrimMonad (ST s) where + type PrimState (ST s) = s + type PrimVar (ST s) = STRef s + primitive = ST + {-# INLINE primitive #-} + primThrow = unsafeIOToST . throwIO + unPrimMonad (ST p) = p + {-# INLINE unPrimMonad #-} + primVarNew = newSTRef + primVarRead = readSTRef + primVarWrite = writeSTRef + +-- | Convert a prim monad to another prim monad. +-- +-- The net effect is that it coerce the state repr to another, +-- so the runtime representation should be the same, otherwise +-- hilary ensues. +unsafePrimCast :: (PrimMonad m1, PrimMonad m2) => m1 a -> m2 a +unsafePrimCast m = primitive (unsafeCoerce# (unPrimMonad m)) +{-# INLINE unsafePrimCast #-} + +-- | Convert any prim monad to an ST monad +unsafePrimToST :: PrimMonad prim => prim a -> ST s a +unsafePrimToST = unsafePrimCast +{-# INLINE unsafePrimToST #-} + +-- | Convert any prim monad to an IO monad +unsafePrimToIO :: PrimMonad prim => prim a -> IO a +unsafePrimToIO = unsafePrimCast +{-# INLINE unsafePrimToIO #-} + +-- | Convert any IO monad to a prim monad +unsafePrimFromIO :: PrimMonad prim => IO a -> prim a +unsafePrimFromIO = unsafePrimCast +{-# INLINE unsafePrimFromIO #-} + +-- | Touch primitive lifted to any prim monad +primTouch :: PrimMonad m => a -> m () +primTouch x = unsafePrimFromIO $ primitive $ \s -> case touch# x s of { s2 -> (# s2, () #) } +{-# INLINE primTouch #-} + +-- | Monad that can represent failure +-- +-- Similar to MonadFail but with a parametrized Failure linked to the Monad +class Monad m => MonadFailure m where + -- | The associated type with the MonadFailure, representing what + -- failure can be encoded in this monad + type Failure m + + -- | Raise a Failure through a monad. + mFail :: Failure m -> m () + +instance MonadFailure Prelude.Maybe where + type Failure Prelude.Maybe = () + mFail _ = Prelude.Nothing +instance MonadFailure (Prelude.Either a) where + type Failure (Prelude.Either a) = a + mFail a = Prelude.Left a diff --git a/bundled/Basement/MutableBuilder.hs b/bundled/Basement/MutableBuilder.hs new file mode 100644 index 0000000..1aa6fc0 --- /dev/null +++ b/bundled/Basement/MutableBuilder.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Basement.MutableBuilder + ( Builder(..) + , BuildingState(..) + ) where + +import Basement.Compat.Base +import Basement.Compat.MonadTrans +import Basement.Types.OffsetSize +import Basement.Monad + +newtype Builder collection mutCollection step state err a = Builder + { runBuilder :: State (Offset step, BuildingState collection mutCollection step (PrimState state), Maybe err) state a } + deriving (Functor, Applicative, Monad) + +-- | The in-progress state of a building operation. +-- +-- The previous buffers are in reverse order, and +-- this contains the current buffer and the state of +-- progress packing the elements inside. +data BuildingState collection mutCollection step state = BuildingState + { prevChunks :: [collection] + , prevChunksSize :: !(CountOf step) + , curChunk :: mutCollection state + , chunkSize :: !(CountOf step) + } + +instance Monad state => MonadFailure (Builder collection mutCollection step state err) where + type Failure (Builder collection mutCollection step state err) = err + mFail builderError = Builder $ State $ \(offset, bs, _) -> + return ((), (offset, bs, Just builderError)) diff --git a/bundled/Basement/Nat.hs b/bundled/Basement/Nat.hs new file mode 100644 index 0000000..f7ffd4b --- /dev/null +++ b/bundled/Basement/Nat.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE NoStarIsType #-} +#endif +module Basement.Nat + ( Nat + , KnownNat + , natVal + , type (<=), type (<=?), type (+), type (*), type (^), type (-) + , CmpNat + -- * Nat convertion + , natValNatural + , natValInt + , natValInt8 + , natValInt16 + , natValInt32 + , natValInt64 + , natValWord + , natValWord8 + , natValWord16 + , natValWord32 + , natValWord64 + -- * Maximum bounds + , NatNumMaxBound + -- * Constraint + , NatInBoundOf + , NatWithinBound + ) where + +#include "MachDeps.h" + +import GHC.TypeLits +import Basement.Compat.Base +import Basement.Compat.Natural +import Basement.Types.Char7 (Char7) +import Basement.Types.Word128 (Word128) +import Basement.Types.Word256 (Word256) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word8, Word16, Word32, Word64) +import qualified Prelude (fromIntegral) + +#if __GLASGOW_HASKELL__ >= 800 +import Data.Type.Bool +#endif + +natValNatural :: forall n proxy . KnownNat n => proxy n -> Natural +natValNatural n = Prelude.fromIntegral (natVal n) + +natValInt :: forall n proxy . (KnownNat n, NatWithinBound Int n) => proxy n -> Int +natValInt n = Prelude.fromIntegral (natVal n) + +natValInt64 :: forall n proxy . (KnownNat n, NatWithinBound Int64 n) => proxy n -> Int64 +natValInt64 n = Prelude.fromIntegral (natVal n) + +natValInt32 :: forall n proxy . (KnownNat n, NatWithinBound Int32 n) => proxy n -> Int32 +natValInt32 n = Prelude.fromIntegral (natVal n) + +natValInt16 :: forall n proxy . (KnownNat n, NatWithinBound Int16 n) => proxy n -> Int16 +natValInt16 n = Prelude.fromIntegral (natVal n) + +natValInt8 :: forall n proxy . (KnownNat n, NatWithinBound Int8 n) => proxy n -> Int8 +natValInt8 n = Prelude.fromIntegral (natVal n) + +natValWord :: forall n proxy . (KnownNat n, NatWithinBound Word n) => proxy n -> Word +natValWord n = Prelude.fromIntegral (natVal n) + +natValWord64 :: forall n proxy . (KnownNat n, NatWithinBound Word64 n) => proxy n -> Word64 +natValWord64 n = Prelude.fromIntegral (natVal n) + +natValWord32 :: forall n proxy . (KnownNat n, NatWithinBound Word32 n) => proxy n -> Word32 +natValWord32 n = Prelude.fromIntegral (natVal n) + +natValWord16 :: forall n proxy . (KnownNat n, NatWithinBound Word16 n) => proxy n -> Word16 +natValWord16 n = Prelude.fromIntegral (natVal n) + +natValWord8 :: forall n proxy . (KnownNat n, NatWithinBound Word8 n) => proxy n -> Word8 +natValWord8 n = Prelude.fromIntegral (natVal n) + +-- | Get Maximum bounds of different Integral / Natural types related to Nat +type family NatNumMaxBound ty :: Nat + +type instance NatNumMaxBound Char = 0x10ffff +type instance NatNumMaxBound Char7 = 0x7f +type instance NatNumMaxBound Int64 = 0x7fffffffffffffff +type instance NatNumMaxBound Int32 = 0x7fffffff +type instance NatNumMaxBound Int16 = 0x7fff +type instance NatNumMaxBound Int8 = 0x7f +type instance NatNumMaxBound Word256 = 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +type instance NatNumMaxBound Word128 = 0xffffffffffffffffffffffffffffffff +type instance NatNumMaxBound Word64 = 0xffffffffffffffff +type instance NatNumMaxBound Word32 = 0xffffffff +type instance NatNumMaxBound Word16 = 0xffff +type instance NatNumMaxBound Word8 = 0xff +#if WORD_SIZE_IN_BITS == 64 +type instance NatNumMaxBound Int = NatNumMaxBound Int64 +type instance NatNumMaxBound Word = NatNumMaxBound Word64 +#else +type instance NatNumMaxBound Int = NatNumMaxBound Int32 +type instance NatNumMaxBound Word = NatNumMaxBound Word32 +#endif + +-- | Check if a Nat is in bounds of another integral / natural types +type family NatInBoundOf ty n where + NatInBoundOf Integer n = 'True + NatInBoundOf Natural n = 'True + NatInBoundOf ty n = n <=? NatNumMaxBound ty + +-- | Constraint to check if a natural is within a specific bounds of a type. +-- +-- i.e. given a Nat `n`, is it possible to convert it to `ty` without losing information +#if __GLASGOW_HASKELL__ >= 800 +type family NatWithinBound ty (n :: Nat) where + NatWithinBound ty n = If (NatInBoundOf ty n) + (() ~ ()) + (TypeError ('Text "Natural " ':<>: 'ShowType n ':<>: 'Text " is out of bounds for " ':<>: 'ShowType ty)) +#else +type NatWithinBound ty n = NatInBoundOf ty n ~ 'True +#endif diff --git a/bundled/Basement/NonEmpty.hs b/bundled/Basement/NonEmpty.hs new file mode 100644 index 0000000..0f2e641 --- /dev/null +++ b/bundled/Basement/NonEmpty.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.NonEmpty +-- License : BSD-style +-- Maintainer : Foundation +-- Stability : experimental +-- Portability : portable +-- +-- A newtype wrapper around a non-empty Collection. + +module Basement.NonEmpty + ( NonEmpty(..) + ) where + +import Basement.Exception +import Basement.Compat.Base + +-- | NonEmpty property for any Collection +newtype NonEmpty a = NonEmpty { getNonEmpty :: a } + deriving (Show,Eq) + +instance IsList c => IsList (NonEmpty c) where + type Item (NonEmpty c) = Item c + toList = toList . getNonEmpty + fromList [] = throw NonEmptyCollectionIsEmpty + fromList l = NonEmpty . fromList $ l diff --git a/bundled/Basement/NormalForm.hs b/bundled/Basement/NormalForm.hs new file mode 100644 index 0000000..d772a30 --- /dev/null +++ b/bundled/Basement/NormalForm.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Basement.NormalForm + ( NormalForm(..) + , deepseq + , force + ) where + +import Basement.Compat.Base +import Basement.Compat.C.Types +import Basement.Compat.Natural +import Basement.Types.OffsetSize +import Basement.Types.Char7 +import Basement.Types.Word128 (Word128) +import Basement.Types.Word256 (Word256) +import Basement.Bounded +import Basement.Endianness + +-- | Data that can be fully evaluated in Normal Form +-- +class NormalForm a where + toNormalForm :: a -> () + +deepseq :: NormalForm a => a -> b -> b +deepseq a b = toNormalForm a `seq` b + +force :: NormalForm a => a -> a +force a = toNormalForm a `seq` a + +----- +-- GHC / base types + +instance NormalForm Int8 where toNormalForm !_ = () +instance NormalForm Int16 where toNormalForm !_ = () +instance NormalForm Int32 where toNormalForm !_ = () +instance NormalForm Int64 where toNormalForm !_ = () +instance NormalForm Int where toNormalForm !_ = () +instance NormalForm Integer where toNormalForm !_ = () + +instance NormalForm Word8 where toNormalForm !_ = () +instance NormalForm Word16 where toNormalForm !_ = () +instance NormalForm Word32 where toNormalForm !_ = () +instance NormalForm Word64 where toNormalForm !_ = () +instance NormalForm Word where toNormalForm !_ = () +instance NormalForm Natural where toNormalForm !_ = () + +instance NormalForm Float where toNormalForm !_ = () +instance NormalForm Double where toNormalForm !_ = () + +instance NormalForm Char where toNormalForm !_ = () +instance NormalForm Bool where toNormalForm !_ = () +instance NormalForm () where toNormalForm !_ = () + +----- +-- C Types +instance NormalForm CChar where toNormalForm !_ = () +instance NormalForm CUChar where toNormalForm !_ = () +instance NormalForm CSChar where toNormalForm !_ = () + +instance NormalForm CShort where toNormalForm !_ = () +instance NormalForm CUShort where toNormalForm !_ = () +instance NormalForm CInt where toNormalForm !_ = () +instance NormalForm CUInt where toNormalForm !_ = () +instance NormalForm CLong where toNormalForm !_ = () +instance NormalForm CULong where toNormalForm !_ = () +instance NormalForm CLLong where toNormalForm !_ = () +instance NormalForm CULLong where toNormalForm !_ = () + +instance NormalForm CFloat where toNormalForm !_ = () +instance NormalForm CDouble where toNormalForm !_ = () + +instance NormalForm (Ptr a) where toNormalForm !_ = () + +----- +-- Basic Foundation primitive types +instance NormalForm (Offset a) where toNormalForm !_ = () +instance NormalForm (CountOf a) where toNormalForm !_ = () + +instance NormalForm Char7 where toNormalForm !_ = () +instance NormalForm Word128 where toNormalForm !_ = () +instance NormalForm Word256 where toNormalForm !_ = () +instance NormalForm (Zn n) where toNormalForm = toNormalForm . unZn +instance NormalForm (Zn64 n) where toNormalForm = toNormalForm . unZn64 + +----- +-- composed type + +instance NormalForm a => NormalForm (Maybe a) where + toNormalForm Nothing = () + toNormalForm (Just a) = toNormalForm a `seq` () +instance (NormalForm l, NormalForm r) => NormalForm (Either l r) where + toNormalForm (Left l) = toNormalForm l `seq` () + toNormalForm (Right r) = toNormalForm r `seq` () +instance NormalForm a => NormalForm (LE a) where + toNormalForm (LE a) = toNormalForm a `seq` () +instance NormalForm a => NormalForm (BE a) where + toNormalForm (BE a) = toNormalForm a `seq` () + +instance NormalForm a => NormalForm [a] where + toNormalForm [] = () + toNormalForm (x:xs) = toNormalForm x `seq` toNormalForm xs + +instance (NormalForm a, NormalForm b) => NormalForm (a,b) where + toNormalForm (a,b) = toNormalForm a `seq` toNormalForm b + +instance (NormalForm a, NormalForm b, NormalForm c) => NormalForm (a,b,c) where + toNormalForm (a,b,c) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c + +instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d) => NormalForm (a,b,c,d) where + toNormalForm (a,b,c,d) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d + +instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e) + => NormalForm (a,b,c,d,e) where + toNormalForm (a,b,c,d,e) = + toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq` + toNormalForm e + +instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f) + => NormalForm (a,b,c,d,e,f) where + toNormalForm (a,b,c,d,e,f) = + toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq` + toNormalForm e `seq` toNormalForm f + +instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f, NormalForm g) + => NormalForm (a,b,c,d,e,f,g) where + toNormalForm (a,b,c,d,e,f,g) = + toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq` + toNormalForm e `seq` toNormalForm f `seq` toNormalForm g +instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f, NormalForm g, NormalForm h) + => NormalForm (a,b,c,d,e,f,g,h) where + toNormalForm (a,b,c,d,e,f,g,h) = + toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq` + toNormalForm e `seq` toNormalForm f `seq` toNormalForm g `seq` toNormalForm h diff --git a/bundled/Basement/Numerical/Additive.hs b/bundled/Basement/Numerical/Additive.hs new file mode 100644 index 0000000..19678ae --- /dev/null +++ b/bundled/Basement/Numerical/Additive.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DefaultSignatures #-} +{-# OPTIONS_GHC -fno-prof-auto #-} +module Basement.Numerical.Additive + ( Additive(..) + ) where + +#include "MachDeps.h" + +import Basement.Compat.Base +import Basement.Compat.C.Types +import Basement.Compat.Natural +import Basement.Compat.Primitive +import Basement.Numerical.Number +import qualified Prelude +import GHC.Types (Float(..), Double(..)) +import GHC.Prim (plusWord#, plusFloat#, (+#), (+##)) +import qualified GHC.Prim +import GHC.Int +import GHC.Word +import Basement.Bounded +import Basement.Nat +import Basement.Types.Word128 (Word128) +import Basement.Types.Word256 (Word256) +import qualified Basement.Types.Word128 as Word128 +import qualified Basement.Types.Word256 as Word256 + +#if WORD_SIZE_IN_BITS < 64 +import GHC.IntWord64 +#endif + +-- | Represent class of things that can be added together, +-- contains a neutral element and is commutative. +-- +-- > x + azero = x +-- > azero + x = x +-- > x + y = y + x +-- +class Additive a where + {-# MINIMAL azero, (+) #-} + azero :: a -- the identity element over addition + (+) :: a -> a -> a -- the addition + + scale :: IsNatural n => n -> a -> a -- scale: repeated addition + default scale :: (Enum n, IsNatural n) => n -> a -> a + scale = scaleEnum + +scaleEnum :: (Enum n, IsNatural n, Additive a) => n -> a -> a +scaleEnum 0 _ = azero +scaleEnum 1 a = a +scaleEnum 2 a = a + a +scaleEnum n a = a + scaleEnum (pred n) a -- TODO optimise. define by group of 2. + +infixl 6 + + +instance Additive Integer where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive Int where + azero = 0 + (I# a) + (I# b) = I# (a +# b) + scale = scaleNum +instance Additive Int8 where + azero = 0 + (I8# a) + (I8# b) = I8# (a `plusInt8#` b) + scale = scaleNum +instance Additive Int16 where + azero = 0 + (I16# a) + (I16# b) = I16# (a `plusInt16#` b) + scale = scaleNum +instance Additive Int32 where + azero = 0 + (I32# a) + (I32# b) = I32# (a `plusInt32#` b) + scale = scaleNum +instance Additive Int64 where + azero = 0 +#if WORD_SIZE_IN_BITS == 64 +#if __GLASGOW_HASKELL__ >= 904 + (I64# a) + (I64# b) = I64# (GHC.Prim.intToInt64# (GHC.Prim.int64ToInt# a +# GHC.Prim.int64ToInt# b)) + +#else + (I64# a) + (I64# b) = I64# (a +# b) + +#endif +#else + (I64# a) + (I64# b) = I64# (a `plusInt64#` b) +#endif + scale = scaleNum +instance Additive Word where + azero = 0 + (W# a) + (W# b) = W# (a `plusWord#` b) + scale = scaleNum +instance Additive Natural where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive Word8 where + azero = 0 + (W8# a) + (W8# b) = W8# (a `plusWord8#` b) + scale = scaleNum +instance Additive Word16 where + azero = 0 + (W16# a) + (W16# b) = W16# (a `plusWord16#` b) + scale = scaleNum +instance Additive Word32 where + azero = 0 + (W32# a) + (W32# b) = W32# (a `plusWord32#` b) + scale = scaleNum +instance Additive Word64 where + azero = 0 +#if WORD_SIZE_IN_BITS == 64 +#if __GLASGOW_HASKELL__ >= 904 + (W64# a) + (W64# b) = W64# (GHC.Prim.wordToWord64# (GHC.Prim.word64ToWord# a `plusWord#` GHC.Prim.word64ToWord# b)) + +#else + (W64# a) + (W64# b) = W64# (a `plusWord#` b) + +#endif +#else + (W64# a) + (W64# b) = W64# (int64ToWord64# (word64ToInt64# a `plusInt64#` word64ToInt64# b)) +#endif + scale = scaleNum +instance Additive Word128 where + azero = 0 + (+) = (Word128.+) + scale = scaleNum +instance Additive Word256 where + azero = 0 + (+) = (Word256.+) + scale = scaleNum + +instance Additive Prelude.Float where + azero = 0.0 + (F# a) + (F# b) = F# (a `plusFloat#` b) + scale = scaleNum +instance Additive Prelude.Double where + azero = 0.0 + (D# a) + (D# b) = D# (a +## b) + scale = scaleNum +instance Additive Prelude.Rational where + azero = 0.0 + (+) = (Prelude.+) + scale = scaleNum + +instance (KnownNat n, NatWithinBound Word64 n) => Additive (Zn64 n) where + azero = zn64 0 + (+) = (Prelude.+) + scale = scaleNum +instance KnownNat n => Additive (Zn n) where + azero = zn 0 + (+) = (Prelude.+) + scale = scaleNum + +instance Additive CChar where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CSChar where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CUChar where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CShort where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CUShort where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CInt where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CUInt where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CLong where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CULong where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CPtrdiff where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CSize where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CWchar where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CSigAtomic where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CLLong where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CULLong where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CIntPtr where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CUIntPtr where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CIntMax where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CUIntMax where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CClock where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CTime where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CUSeconds where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CSUSeconds where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive COff where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum + +instance Additive CFloat where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum +instance Additive CDouble where + azero = 0 + (+) = (Prelude.+) + scale = scaleNum + +scaleNum :: (Prelude.Num a, IsNatural n) => n -> a -> a +scaleNum n a = (Prelude.fromIntegral $ toNatural n) Prelude.* a diff --git a/bundled/Basement/Numerical/Conversion.hs b/bundled/Basement/Numerical/Conversion.hs new file mode 100644 index 0000000..0ba6299 --- /dev/null +++ b/bundled/Basement/Numerical/Conversion.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +module Basement.Numerical.Conversion + ( intToInt64 + , int64ToInt + , intToWord + , wordToWord64 + , word64ToWord + , Word32x2(..) + , word64ToWord32s + , wordToChar + , wordToInt + , word64ToWord# + , charToInt + , int64ToWord64 + , word64ToInt64 + ) where + +#include "MachDeps.h" + +import GHC.Types +import GHC.Prim hiding (word64ToWord#) +import qualified GHC.Prim +import GHC.Int +import GHC.Word +import Basement.Compat.Primitive + +#if WORD_SIZE_IN_BITS < 64 +import GHC.IntWord64 +#endif + +intToInt64 :: Int -> Int64 +#if WORD_SIZE_IN_BITS == 64 +#if __GLASGOW_HASKELL__ >= 904 +intToInt64 (I# i) = I64# (intToInt64# i) +#else +intToInt64 (I# i) = I64# i +#endif +#else +intToInt64 (I# i) = I64# (intToInt64# i) +#endif + +int64ToInt :: Int64 -> Int +#if WORD_SIZE_IN_BITS == 64 +#if __GLASGOW_HASKELL__ >= 904 +int64ToInt (I64# i) = I# (int64ToInt# i) +#else +int64ToInt (I64# i) = I# i +#endif +#else +int64ToInt (I64# i) = I# (int64ToInt# i) +#endif + +wordToWord64 :: Word -> Word64 +#if WORD_SIZE_IN_BITS == 64 +#if __GLASGOW_HASKELL__ >= 904 +wordToWord64 (W# i) = W64# (wordToWord64# i) +#else +wordToWord64 (W# i) = W64# i +#endif +#else +wordToWord64 (W# i) = W64# (wordToWord64# i) +#endif + +word64ToWord :: Word64 -> Word +#if WORD_SIZE_IN_BITS == 64 +#if __GLASGOW_HASKELL__ >= 904 +word64ToWord (W64# i) = W# (GHC.Prim.word64ToWord# i) +#else +word64ToWord (W64# i) = W# i +#endif +#else +word64ToWord (W64# i) = W# (word64ToWord# i) +#endif + +word64ToInt64 :: Word64 -> Int64 +#if WORD_SIZE_IN_BITS == 64 +#if __GLASGOW_HASKELL__ >= 904 +word64ToInt64 (W64# i) = I64# (word64ToInt64# i) +#else +word64ToInt64 (W64# i) = I64# (word2Int# i) +#endif +#else +word64ToInt64 (W64# i) = I64# (word64ToInt64# i) +#endif + +int64ToWord64 :: Int64 -> Word64 +#if WORD_SIZE_IN_BITS == 64 +#if __GLASGOW_HASKELL__ >= 904 +int64ToWord64 (I64# i) = W64# (int64ToWord64# i) +#else +int64ToWord64 (I64# i) = W64# (int2Word# i) +#endif +#else +int64ToWord64 (I64# i) = W64# (int64ToWord64# i) +#endif + +#if WORD_SIZE_IN_BITS == 64 +word64ToWord# :: Word# -> Word# +word64ToWord# i = i +{-# INLINE word64ToWord# #-} +#endif + +-- | 2 Word32s +data Word32x2 = Word32x2 {-# UNPACK #-} !Word32 + {-# UNPACK #-} !Word32 + +#if WORD_SIZE_IN_BITS == 64 +word64ToWord32s :: Word64 -> Word32x2 +#if __GLASGOW_HASKELL__ >= 904 +word64ToWord32s (W64# w64) = Word32x2 (W32# (wordToWord32# (uncheckedShiftRL# (GHC.Prim.word64ToWord# w64 ) 32#))) (W32# (wordToWord32# (GHC.Prim.word64ToWord# w64))) +#else +word64ToWord32s (W64# w64) = Word32x2 (W32# (wordToWord32# (uncheckedShiftRL# w64 32#))) (W32# (wordToWord32# w64)) +#endif +#else +word64ToWord32s :: Word64 -> Word32x2 +word64ToWord32s (W64# w64) = Word32x2 (W32# (word64ToWord# (uncheckedShiftRL64# w64 32#))) (W32# (word64ToWord# w64)) +#endif + +wordToChar :: Word -> Char +wordToChar (W# word) = C# (chr# (word2Int# word)) + +wordToInt :: Word -> Int +wordToInt (W# word) = I# (word2Int# word) + +intToWord :: Int -> Word +intToWord (I# i) = W# (int2Word# i) + +charToInt :: Char -> Int +charToInt (C# x) = I# (ord# x) diff --git a/bundled/Basement/Numerical/Multiplicative.hs b/bundled/Basement/Numerical/Multiplicative.hs new file mode 100644 index 0000000..27d8fb2 --- /dev/null +++ b/bundled/Basement/Numerical/Multiplicative.hs @@ -0,0 +1,331 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DefaultSignatures #-} +module Basement.Numerical.Multiplicative + ( Multiplicative(..) + , IDivisible(..) + , Divisible(..) + , recip + ) where + +import Basement.Compat.Base +import Basement.Compat.C.Types +import Basement.Compat.Natural +import Basement.Compat.NumLiteral +import Basement.Numerical.Number +import Basement.Numerical.Additive +import Basement.Types.Word128 (Word128) +import Basement.Types.Word256 (Word256) +import qualified Basement.Types.Word128 as Word128 +import qualified Basement.Types.Word256 as Word256 +import qualified Prelude + +-- | Represent class of things that can be multiplied together +-- +-- > x * midentity = x +-- > midentity * x = x +class Multiplicative a where + {-# MINIMAL midentity, (*) #-} + -- | Identity element over multiplication + midentity :: a + + -- | Multiplication of 2 elements that result in another element + (*) :: a -> a -> a + + -- | Raise to power, repeated multiplication + -- e.g. + -- > a ^ 2 = a * a + -- > a ^ 10 = (a ^ 5) * (a ^ 5) .. + --(^) :: (IsNatural n) => a -> n -> a + (^) :: (IsNatural n, Enum n, IDivisible n) => a -> n -> a + (^) = power + +-- | Represent types that supports an euclidian division +-- +-- > (x ‘div‘ y) * y + (x ‘mod‘ y) == x +class (Additive a, Multiplicative a) => IDivisible a where + {-# MINIMAL (div, mod) | divMod #-} + div :: a -> a -> a + div a b = fst $ divMod a b + mod :: a -> a -> a + mod a b = snd $ divMod a b + divMod :: a -> a -> (a, a) + divMod a b = (div a b, mod a b) + +-- | Support for division between same types +-- +-- This is likely to change to represent specific mathematic divisions +class Multiplicative a => Divisible a where + {-# MINIMAL (/) #-} + (/) :: a -> a -> a + +infixl 7 *, / +infixr 8 ^ + +instance Multiplicative Integer where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative Int where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative Int8 where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative Int16 where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative Int32 where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative Int64 where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative Natural where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative Word where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative Word8 where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative Word16 where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative Word32 where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative Word64 where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative Word128 where + midentity = 1 + (*) = (Word128.*) +instance Multiplicative Word256 where + midentity = 1 + (*) = (Word256.*) + +instance Multiplicative Prelude.Float where + midentity = 1.0 + (*) = (Prelude.*) +instance Multiplicative Prelude.Double where + midentity = 1.0 + (*) = (Prelude.*) +instance Multiplicative Prelude.Rational where + midentity = 1.0 + (*) = (Prelude.*) + +instance Multiplicative CChar where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CSChar where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CUChar where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CShort where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CUShort where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CInt where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CUInt where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CLong where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CULong where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CPtrdiff where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CSize where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CWchar where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CSigAtomic where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CLLong where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CULLong where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CIntPtr where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CUIntPtr where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CIntMax where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CUIntMax where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CClock where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CTime where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CUSeconds where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative CSUSeconds where + midentity = 1 + (*) = (Prelude.*) +instance Multiplicative COff where + midentity = 1 + (*) = (Prelude.*) + +instance Multiplicative CFloat where + midentity = 1.0 + (*) = (Prelude.*) +instance Multiplicative CDouble where + midentity = 1.0 + (*) = (Prelude.*) + +instance IDivisible Integer where + div = Prelude.div + mod = Prelude.mod +instance IDivisible Int where + div = Prelude.div + mod = Prelude.mod +instance IDivisible Int8 where + div = Prelude.div + mod = Prelude.mod +instance IDivisible Int16 where + div = Prelude.div + mod = Prelude.mod +instance IDivisible Int32 where + div = Prelude.div + mod = Prelude.mod +instance IDivisible Int64 where + div = Prelude.div + mod = Prelude.mod +instance IDivisible Natural where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible Word where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible Word8 where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible Word16 where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible Word32 where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible Word64 where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible Word128 where + div = Word128.quot + mod = Word128.rem +instance IDivisible Word256 where + div = Word256.quot + mod = Word256.rem + +instance IDivisible CChar where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CSChar where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CUChar where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CShort where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CUShort where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CInt where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CUInt where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CLong where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CULong where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CPtrdiff where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CSize where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CWchar where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CSigAtomic where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CLLong where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CULLong where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CIntPtr where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CUIntPtr where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CIntMax where + div = Prelude.quot + mod = Prelude.rem +instance IDivisible CUIntMax where + div = Prelude.quot + mod = Prelude.rem + +instance Divisible Prelude.Rational where + (/) = (Prelude./) +instance Divisible Float where + (/) = (Prelude./) +instance Divisible Double where + (/) = (Prelude./) + +instance Divisible CFloat where + (/) = (Prelude./) +instance Divisible CDouble where + (/) = (Prelude./) + +recip :: Divisible a => a -> a +recip x = midentity / x + +power :: (Enum n, IsNatural n, IDivisible n, Multiplicative a) => a -> n -> a +power a n + | n == 0 = midentity + | otherwise = squaring midentity a n + where + squaring y x i + | i == 0 = y + | i == 1 = x * y + | even i = squaring y (x*x) (i`div`2) + | otherwise = squaring (x*y) (x*x) (pred i`div` 2) + +even :: (IDivisible n, IsIntegral n) => n -> Bool +even n = (n `mod` 2) == 0 diff --git a/bundled/Basement/Numerical/Number.hs b/bundled/Basement/Numerical/Number.hs new file mode 100644 index 0000000..215726c --- /dev/null +++ b/bundled/Basement/Numerical/Number.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# Language CPP #-} +module Basement.Numerical.Number + ( IsIntegral(..) + , IsNatural(..) + ) where + +import Basement.Compat.Base +import Basement.Compat.C.Types +import Basement.Compat.Natural +import Basement.Compat.NumLiteral +import Data.Bits +import qualified Prelude + +-- | Number literals, convertible through the generic Integer type. +-- +-- all number are Enum'erable, meaning that you can move to +-- next element +class (Integral a, Eq a, Ord a) => IsIntegral a where + {-# MINIMAL toInteger #-} + toInteger :: a -> Integer + +-- | Non Negative Number literals, convertible through the generic Natural type +class IsIntegral a => IsNatural a where + {-# MINIMAL toNatural #-} + toNatural :: a -> Natural + +instance IsIntegral Integer where + toInteger i = i +instance IsIntegral Int where + toInteger i = Prelude.toInteger i +instance IsIntegral Int8 where + toInteger i = Prelude.toInteger i +instance IsIntegral Int16 where + toInteger i = Prelude.toInteger i +instance IsIntegral Int32 where + toInteger i = Prelude.toInteger i +instance IsIntegral Int64 where + toInteger i = Prelude.toInteger i +instance IsIntegral Natural where + toInteger i = Prelude.toInteger i +instance IsIntegral Word where + toInteger i = Prelude.toInteger i +instance IsIntegral Word8 where + toInteger i = Prelude.toInteger i +instance IsIntegral Word16 where + toInteger i = Prelude.toInteger i +instance IsIntegral Word32 where + toInteger i = Prelude.toInteger i +instance IsIntegral Word64 where + toInteger i = Prelude.toInteger i + +instance IsIntegral CChar where + toInteger i = Prelude.toInteger i +instance IsIntegral CSChar where + toInteger i = Prelude.toInteger i +instance IsIntegral CUChar where + toInteger i = Prelude.toInteger i +instance IsIntegral CShort where + toInteger i = Prelude.toInteger i +instance IsIntegral CUShort where + toInteger i = Prelude.toInteger i +instance IsIntegral CInt where + toInteger i = Prelude.toInteger i +instance IsIntegral CUInt where + toInteger i = Prelude.toInteger i +instance IsIntegral CLong where + toInteger i = Prelude.toInteger i +instance IsIntegral CULong where + toInteger i = Prelude.toInteger i +instance IsIntegral CPtrdiff where + toInteger i = Prelude.toInteger i +instance IsIntegral CSize where + toInteger i = Prelude.toInteger i +instance IsIntegral CWchar where + toInteger i = Prelude.toInteger i +instance IsIntegral CSigAtomic where + toInteger i = Prelude.toInteger i +instance IsIntegral CLLong where + toInteger i = Prelude.toInteger i +instance IsIntegral CULLong where + toInteger i = Prelude.toInteger i +#if MIN_VERSION_base(4,10,0) +instance IsIntegral CBool where + toInteger i = Prelude.toInteger i +#endif +instance IsIntegral CIntPtr where + toInteger i = Prelude.toInteger i +instance IsIntegral CUIntPtr where + toInteger i = Prelude.toInteger i +instance IsIntegral CIntMax where + toInteger i = Prelude.toInteger i +instance IsIntegral CUIntMax where + toInteger i = Prelude.toInteger i + +instance IsNatural Natural where + toNatural i = i +instance IsNatural Word where + toNatural i = Prelude.fromIntegral i +instance IsNatural Word8 where + toNatural i = Prelude.fromIntegral i +instance IsNatural Word16 where + toNatural i = Prelude.fromIntegral i +instance IsNatural Word32 where + toNatural i = Prelude.fromIntegral i +instance IsNatural Word64 where + toNatural i = Prelude.fromIntegral i + +instance IsNatural CUChar where + toNatural i = Prelude.fromIntegral i +instance IsNatural CUShort where + toNatural i = Prelude.fromIntegral i +instance IsNatural CUInt where + toNatural i = Prelude.fromIntegral i +instance IsNatural CULong where + toNatural i = Prelude.fromIntegral i +instance IsNatural CSize where + toNatural i = Prelude.fromIntegral i +instance IsNatural CULLong where + toNatural i = Prelude.fromIntegral i +instance IsNatural CUIntPtr where + toNatural i = Prelude.fromIntegral i +instance IsNatural CUIntMax where + toNatural i = Prelude.fromIntegral i diff --git a/bundled/Basement/Numerical/Subtractive.hs b/bundled/Basement/Numerical/Subtractive.hs new file mode 100644 index 0000000..8f2ec71 --- /dev/null +++ b/bundled/Basement/Numerical/Subtractive.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP, UndecidableInstances, TypeFamilies #-} +module Basement.Numerical.Subtractive + ( Subtractive(..) + ) where + +import Basement.Compat.Base +import Basement.Compat.C.Types +import Basement.Compat.Natural +import Basement.IntegralConv +import Basement.Bounded +import Basement.Nat +import Basement.Types.Word128 (Word128) +import Basement.Types.Word256 (Word256) +import qualified Basement.Types.Word128 as Word128 +import qualified Basement.Types.Word256 as Word256 +import qualified Prelude + +-- | Represent class of things that can be subtracted. +-- +-- +-- Note that the result is not necessary of the same type +-- as the operand depending on the actual type. +-- +-- For example: +-- +-- > (-) :: Int -> Int -> Int +-- > (-) :: DateTime -> DateTime -> Seconds +-- > (-) :: Ptr a -> Ptr a -> PtrDiff +-- > (-) :: Natural -> Natural -> Maybe Natural +class Subtractive a where + type Difference a + (-) :: a -> a -> Difference a + +infixl 6 - + +instance Subtractive Integer where + type Difference Integer = Integer + (-) = (Prelude.-) +instance Subtractive Int where + type Difference Int = Int + (-) = (Prelude.-) +instance Subtractive Int8 where + type Difference Int8 = Int8 + (-) = (Prelude.-) +instance Subtractive Int16 where + type Difference Int16 = Int16 + (-) = (Prelude.-) +instance Subtractive Int32 where + type Difference Int32 = Int32 + (-) = (Prelude.-) +instance Subtractive Int64 where + type Difference Int64 = Int64 + (-) = (Prelude.-) +instance Subtractive Natural where + type Difference Natural = Maybe Natural + (-) a b + | b > a = Nothing + | otherwise = Just (a Prelude.- b) +instance Subtractive Word where + type Difference Word = Word + (-) = (Prelude.-) +instance Subtractive Word8 where + type Difference Word8 = Word8 + (-) = (Prelude.-) +instance Subtractive Word16 where + type Difference Word16 = Word16 + (-) = (Prelude.-) +instance Subtractive Word32 where + type Difference Word32 = Word32 + (-) = (Prelude.-) +instance Subtractive Word64 where + type Difference Word64 = Word64 + (-) = (Prelude.-) +instance Subtractive Word128 where + type Difference Word128 = Word128 + (-) = (Word128.-) +instance Subtractive Word256 where + type Difference Word256 = Word256 + (-) = (Word256.-) + +instance Subtractive Prelude.Float where + type Difference Prelude.Float = Prelude.Float + (-) = (Prelude.-) +instance Subtractive Prelude.Double where + type Difference Prelude.Double = Prelude.Double + (-) = (Prelude.-) + +instance Subtractive Prelude.Char where + type Difference Prelude.Char = Prelude.Int + (-) a b = (Prelude.-) (charToInt a) (charToInt b) +instance (KnownNat n, NatWithinBound Word64 n) => Subtractive (Zn64 n) where + type Difference (Zn64 n) = Zn64 n + (-) a b = (Prelude.-) a b +instance KnownNat n => Subtractive (Zn n) where + type Difference (Zn n) = Zn n + (-) a b = (Prelude.-) a b + +instance Subtractive CChar where + type Difference CChar = CChar + (-) = (Prelude.-) +instance Subtractive CSChar where + type Difference CSChar = CSChar + (-) = (Prelude.-) +instance Subtractive CUChar where + type Difference CUChar = CUChar + (-) = (Prelude.-) +instance Subtractive CShort where + type Difference CShort = CShort + (-) = (Prelude.-) +instance Subtractive CUShort where + type Difference CUShort = CUShort + (-) = (Prelude.-) +instance Subtractive CInt where + type Difference CInt = CInt + (-) = (Prelude.-) +instance Subtractive CUInt where + type Difference CUInt = CUInt + (-) = (Prelude.-) +instance Subtractive CLong where + type Difference CLong = CLong + (-) = (Prelude.-) +instance Subtractive CULong where + type Difference CULong = CULong + (-) = (Prelude.-) +instance Subtractive CPtrdiff where + type Difference CPtrdiff = CPtrdiff + (-) = (Prelude.-) +instance Subtractive CSize where + type Difference CSize = CSize + (-) = (Prelude.-) +instance Subtractive CWchar where + type Difference CWchar = CWchar + (-) = (Prelude.-) +instance Subtractive CSigAtomic where + type Difference CSigAtomic = CSigAtomic + (-) = (Prelude.-) +instance Subtractive CLLong where + type Difference CLLong = CLLong + (-) = (Prelude.-) +instance Subtractive CULLong where + type Difference CULLong = CULLong + (-) = (Prelude.-) +#if MIN_VERSION_base(4,10,0) +instance Subtractive CBool where + type Difference CBool = CBool + (-) = (Prelude.-) +#endif +instance Subtractive CIntPtr where + type Difference CIntPtr = CIntPtr + (-) = (Prelude.-) +instance Subtractive CUIntPtr where + type Difference CUIntPtr = CUIntPtr + (-) = (Prelude.-) +instance Subtractive CIntMax where + type Difference CIntMax = CIntMax + (-) = (Prelude.-) +instance Subtractive CUIntMax where + type Difference CUIntMax = CUIntMax + (-) = (Prelude.-) +instance Subtractive CClock where + type Difference CClock = CClock + (-) = (Prelude.-) +instance Subtractive CTime where + type Difference CTime = CTime + (-) = (Prelude.-) +instance Subtractive CUSeconds where + type Difference CUSeconds = CUSeconds + (-) = (Prelude.-) +instance Subtractive CSUSeconds where + type Difference CSUSeconds = CSUSeconds + (-) = (Prelude.-) +instance Subtractive COff where + type Difference COff = COff + (-) = (Prelude.-) + +instance Subtractive CFloat where + type Difference CFloat = CFloat + (-) = (Prelude.-) +instance Subtractive CDouble where + type Difference CDouble = CDouble + (-) = (Prelude.-) diff --git a/bundled/Basement/PrimType.hs b/bundled/Basement/PrimType.hs new file mode 100644 index 0000000..cc21af0 --- /dev/null +++ b/bundled/Basement/PrimType.hs @@ -0,0 +1,768 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- Module : Basement.PrimType +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +module Basement.PrimType + ( PrimType(..) + , PrimMemoryComparable + , primBaIndex + , primMbaRead + , primMbaWrite + , primArrayIndex + , primMutableArrayRead + , primMutableArrayWrite + , primOffsetOfE + , primOffsetRecast + , sizeRecast + , offsetAsSize + , sizeAsOffset + , sizeInBytes + , offsetInBytes + , offsetInElements + , offsetIsAligned + , primWordGetByteAndShift + , primWord64GetByteAndShift + , primWord64GetHiLo + ) where + +#include "MachDeps.h" + +import GHC.Prim +import GHC.Int +import GHC.Types +import GHC.Word +import Data.Bits +import Data.Proxy +import Basement.Compat.Base +import Basement.Compat.C.Types +import Basement.Numerical.Subtractive +import Basement.Types.OffsetSize +import Basement.Types.Char7 (Char7(..)) +import Basement.Endianness +import Basement.Types.Word128 (Word128(..)) +import Basement.Types.Word256 (Word256(..)) +import Basement.Monad +import Basement.Nat +import qualified Prelude (quot) + +#if WORD_SIZE_IN_BITS < 64 +import GHC.IntWord64 +#endif + +#ifdef FOUNDATION_BOUNDS_CHECK + +divBytes :: PrimType ty => Offset ty -> (Int -> Int) +divBytes ofs = \x -> x `Prelude.quot` (getSize Proxy ofs) + where + getSize :: PrimType ty => Proxy ty -> Offset ty -> Int + getSize p _ = let (CountOf sz) = primSizeInBytes p in sz + +baLength :: PrimType ty => Offset ty -> ByteArray# -> Int +baLength ofs ba = divBytes ofs (I# (sizeofByteArray# ba)) + +mbaLength :: PrimType ty => Offset ty -> MutableByteArray# st -> Int +mbaLength ofs ba = divBytes ofs (I# (sizeofMutableByteArray# ba)) + +aLength :: Array# ty -> Int +aLength ba = I# (sizeofArray# ba) + +maLength :: MutableArray# st ty -> Int +maLength ba = I# (sizeofMutableArray# ba) + +boundCheckError :: [Char] -> Offset ty -> Int -> a +boundCheckError ty (Offset ofs) len = + error (ty <> " offset=" <> show ofs <> " len=" <> show len) + +baCheck :: PrimType ty => ByteArray# -> Offset ty -> Bool +baCheck ba ofs@(Offset o) = o < 0 || o >= baLength ofs ba + +mbaCheck :: PrimType ty => MutableByteArray# st -> Offset ty -> Bool +mbaCheck mba ofs@(Offset o) = o < 0 || o >= mbaLength ofs mba + +aCheck :: Array# ty -> Offset ty -> Bool +aCheck ba (Offset o) = o < 0 || o >= aLength ba + +maCheck :: MutableArray# st ty -> Offset ty -> Bool +maCheck ma (Offset o) = o < 0 || o >= maLength ma + +primBaIndex :: PrimType ty => ByteArray# -> Offset ty -> ty +primBaIndex ba ofs + | baCheck ba ofs = boundCheckError "bytearray-index" ofs (baLength ofs ba) + | otherwise = primBaUIndex ba ofs +{-# NOINLINE primBaIndex #-} + +primMbaRead :: (PrimType ty, PrimMonad prim) => MutableByteArray# (PrimState prim) -> Offset ty -> prim ty +primMbaRead mba ofs + | mbaCheck mba ofs = boundCheckError "mutablebytearray-read" ofs (mbaLength ofs mba) + | otherwise = primMbaURead mba ofs +{-# NOINLINE primMbaRead #-} + +primMbaWrite :: (PrimType ty, PrimMonad prim) => MutableByteArray# (PrimState prim) -> Offset ty -> ty -> prim () +primMbaWrite mba ofs ty + | mbaCheck mba ofs = boundCheckError "mutablebytearray-write" ofs (mbaLength ofs mba) + | otherwise = primMbaUWrite mba ofs ty +{-# NOINLINE primMbaWrite #-} + +primArrayIndex :: Array# ty -> Offset ty -> ty +primArrayIndex a o@(Offset (I# ofs)) + | aCheck a o = boundCheckError "array-index" o (aLength a) + | otherwise = let !(# v #) = indexArray# a ofs in v +{-# NOINLINE primArrayIndex #-} + +primMutableArrayRead :: PrimMonad prim => MutableArray# (PrimState prim) ty -> Offset ty -> prim ty +primMutableArrayRead ma o@(Offset (I# ofs)) + | maCheck ma o = boundCheckError "array-read" o (maLength ma) + | otherwise = primitive $ \s1 -> readArray# ma ofs s1 +{-# NOINLINE primMutableArrayRead #-} + +primMutableArrayWrite :: PrimMonad prim => MutableArray# (PrimState prim) ty -> Offset ty -> ty -> prim () +primMutableArrayWrite ma o@(Offset (I# ofs)) v + | maCheck ma o = boundCheckError "array-write" o (maLength ma) + | otherwise = primitive $ \s1 -> let !s2 = writeArray# ma ofs v s1 in (# s2, () #) +{-# NOINLINE primMutableArrayWrite #-} + +#else + +primBaIndex :: PrimType ty => ByteArray# -> Offset ty -> ty +primBaIndex = primBaUIndex +{-# INLINE primBaIndex #-} + +primMbaRead :: (PrimType ty, PrimMonad prim) => MutableByteArray# (PrimState prim) -> Offset ty -> prim ty +primMbaRead = primMbaURead +{-# INLINE primMbaRead #-} + +primMbaWrite :: (PrimType ty, PrimMonad prim) => MutableByteArray# (PrimState prim) -> Offset ty -> ty -> prim () +primMbaWrite = primMbaUWrite +{-# INLINE primMbaWrite #-} + +primArrayIndex :: Array# ty -> Offset ty -> ty +primArrayIndex a (Offset (I# ofs)) = let !(# v #) = indexArray# a ofs in v +{-# INLINE primArrayIndex #-} + +primMutableArrayRead :: PrimMonad prim => MutableArray# (PrimState prim) ty -> Offset ty -> prim ty +primMutableArrayRead ma (Offset (I# ofs)) = primitive $ \s1 -> readArray# ma ofs s1 +{-# INLINE primMutableArrayRead #-} + +primMutableArrayWrite :: PrimMonad prim => MutableArray# (PrimState prim) ty -> Offset ty -> ty -> prim () +primMutableArrayWrite ma (Offset (I# ofs)) v = + primitive $ \s1 -> let !s2 = writeArray# ma ofs v s1 in (# s2, () #) +{-# INLINE primMutableArrayWrite #-} + +#endif + +-- | Represent the accessor for types that can be stored in the UArray and MUArray. +-- +-- Types need to be a instance of storable and have fixed sized. +class Eq ty => PrimType ty where + -- | type level size of the given `ty` + type PrimSize ty :: Nat + + -- | get the size in bytes of a ty element + primSizeInBytes :: Proxy ty -> CountOf Word8 + + -- | get the shift size + primShiftToBytes :: Proxy ty -> Int + + ----- + -- ByteArray section + ----- + + -- | return the element stored at a specific index + primBaUIndex :: ByteArray# -> Offset ty -> ty + + ----- + -- MutableByteArray section + ----- + + -- | Read an element at an index in a mutable array + primMbaURead :: PrimMonad prim + => MutableByteArray# (PrimState prim) -- ^ mutable array to read from + -> Offset ty -- ^ index of the element to retrieve + -> prim ty -- ^ the element returned + + -- | Write an element to a specific cell in a mutable array. + primMbaUWrite :: PrimMonad prim + => MutableByteArray# (PrimState prim) -- ^ mutable array to modify + -> Offset ty -- ^ index of the element to modify + -> ty -- ^ the new value to store + -> prim () + + ----- + -- Addr# section + ----- + + -- | Read from Address, without a state. the value read should be considered a constant for all + -- pratical purpose, otherwise bad thing will happens. + primAddrIndex :: Addr# -> Offset ty -> ty + + -- | Read a value from Addr in a specific primitive monad + primAddrRead :: PrimMonad prim + => Addr# + -> Offset ty + -> prim ty + -- | Write a value to Addr in a specific primitive monad + primAddrWrite :: PrimMonad prim + => Addr# + -> Offset ty + -> ty + -> prim () + +sizeInt, sizeWord :: CountOf Word8 +shiftInt, shiftWord :: Int +#if WORD_SIZE_IN_BITS == 64 +sizeInt = CountOf 8 +sizeWord = CountOf 8 +shiftInt = 3 +shiftWord = 3 +#else +sizeInt = CountOf 4 +sizeWord = CountOf 4 +shiftInt = 2 +shiftWord = 2 +#endif + +{-# SPECIALIZE [3] primBaUIndex :: ByteArray# -> Offset Word8 -> Word8 #-} + +instance PrimType Int where +#if WORD_SIZE_IN_BITS == 64 + type PrimSize Int = 8 +#else + type PrimSize Int = 4 +#endif + primSizeInBytes _ = sizeInt + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = shiftInt + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset (I# n)) = I# (indexIntArray# ba n) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readIntArray# mba n s1 in (# s2, I# r #) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset (I# n)) (I# w) = primitive $ \s1 -> (# writeIntArray# mba n w s1, () #) + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset (I# n)) = I# (indexIntOffAddr# addr n) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readIntOffAddr# addr n s1 in (# s2, I# r #) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset (I# n)) (I# w) = primitive $ \s1 -> (# writeIntOffAddr# addr n w s1, () #) + {-# INLINE primAddrWrite #-} + +instance PrimType Word where +#if WORD_SIZE_IN_BITS == 64 + type PrimSize Word = 8 +#else + type PrimSize Word = 4 +#endif + primSizeInBytes _ = sizeWord + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = shiftWord + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset (I# n)) = W# (indexWordArray# ba n) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWordArray# mba n s1 in (# s2, W# r #) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset (I# n)) (W# w) = primitive $ \s1 -> (# writeWordArray# mba n w s1, () #) + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset (I# n)) = W# (indexWordOffAddr# addr n) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWordOffAddr# addr n s1 in (# s2, W# r #) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset (I# n)) (W# w) = primitive $ \s1 -> (# writeWordOffAddr# addr n w s1, () #) + {-# INLINE primAddrWrite #-} + +instance PrimType Word8 where + type PrimSize Word8 = 1 + primSizeInBytes _ = CountOf 1 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 0 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset (I# n)) = W8# (indexWord8Array# ba n) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord8Array# mba n s1 in (# s2, W8# r #) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset (I# n)) (W8# w) = primitive $ \s1 -> (# writeWord8Array# mba n w s1, () #) + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset (I# n)) = W8# (indexWord8OffAddr# addr n) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord8OffAddr# addr n s1 in (# s2, W8# r #) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset (I# n)) (W8# w) = primitive $ \s1 -> (# writeWord8OffAddr# addr n w s1, () #) + {-# INLINE primAddrWrite #-} + +instance PrimType Word16 where + type PrimSize Word16 = 2 + primSizeInBytes _ = CountOf 2 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 1 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset (I# n)) = W16# (indexWord16Array# ba n) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord16Array# mba n s1 in (# s2, W16# r #) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset (I# n)) (W16# w) = primitive $ \s1 -> (# writeWord16Array# mba n w s1, () #) + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset (I# n)) = W16# (indexWord16OffAddr# addr n) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord16OffAddr# addr n s1 in (# s2, W16# r #) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset (I# n)) (W16# w) = primitive $ \s1 -> (# writeWord16OffAddr# addr n w s1, () #) + {-# INLINE primAddrWrite #-} +instance PrimType Word32 where + type PrimSize Word32 = 4 + primSizeInBytes _ = CountOf 4 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 2 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset (I# n)) = W32# (indexWord32Array# ba n) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord32Array# mba n s1 in (# s2, W32# r #) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset (I# n)) (W32# w) = primitive $ \s1 -> (# writeWord32Array# mba n w s1, () #) + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset (I# n)) = W32# (indexWord32OffAddr# addr n) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord32OffAddr# addr n s1 in (# s2, W32# r #) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset (I# n)) (W32# w) = primitive $ \s1 -> (# writeWord32OffAddr# addr n w s1, () #) + {-# INLINE primAddrWrite #-} +instance PrimType Word64 where + type PrimSize Word64 = 8 + primSizeInBytes _ = CountOf 8 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 3 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset (I# n)) = W64# (indexWord64Array# ba n) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord64Array# mba n s1 in (# s2, W64# r #) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset (I# n)) (W64# w) = primitive $ \s1 -> (# writeWord64Array# mba n w s1, () #) + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset (I# n)) = W64# (indexWord64OffAddr# addr n) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord64OffAddr# addr n s1 in (# s2, W64# r #) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset (I# n)) (W64# w) = primitive $ \s1 -> (# writeWord64OffAddr# addr n w s1, () #) + {-# INLINE primAddrWrite #-} +instance PrimType Word128 where + type PrimSize Word128 = 16 + primSizeInBytes _ = CountOf 16 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 4 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba n = + Word128 (W64# (indexWord64Array# ba n1)) (W64# (indexWord64Array# ba n2)) + where (# n1, n2 #) = offset128_64 n + {-# INLINE primBaUIndex #-} + primMbaURead mba n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64Array# mba n1 s1 + !(# s3, r2 #) = readWord64Array# mba n2 s2 + in (# s3, Word128 (W64# r1) (W64# r2) #) + where (# n1, n2 #) = offset128_64 n + {-# INLINE primMbaURead #-} + primMbaUWrite mba n (Word128 (W64# w1) (W64# w2)) = primitive $ \s1 -> + let !s2 = writeWord64Array# mba n1 w1 s1 + in (# writeWord64Array# mba n2 w2 s2, () #) + where (# n1, n2 #) = offset128_64 n + {-# INLINE primMbaUWrite #-} + primAddrIndex addr n = Word128 (W64# (indexWord64OffAddr# addr n1)) (W64# (indexWord64OffAddr# addr n2)) + where (# n1, n2 #) = offset128_64 n + {-# INLINE primAddrIndex #-} + primAddrRead addr n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64OffAddr# addr n1 s1 + !(# s3, r2 #) = readWord64OffAddr# addr n2 s2 + in (# s3, Word128 (W64# r1) (W64# r2) #) + where (# n1, n2 #) = offset128_64 n + {-# INLINE primAddrRead #-} + primAddrWrite addr n (Word128 (W64# w1) (W64# w2)) = primitive $ \s1 -> + let !s2 = writeWord64OffAddr# addr n1 w1 s1 + in (# writeWord64OffAddr# addr n2 w2 s2, () #) + where (# n1, n2 #) = offset128_64 n + {-# INLINE primAddrWrite #-} +instance PrimType Word256 where + type PrimSize Word256 = 32 + primSizeInBytes _ = CountOf 32 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 5 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba n = + Word256 (W64# (indexWord64Array# ba n1)) (W64# (indexWord64Array# ba n2)) + (W64# (indexWord64Array# ba n3)) (W64# (indexWord64Array# ba n4)) + where (# n1, n2, n3, n4 #) = offset256_64 n + {-# INLINE primBaUIndex #-} + primMbaURead mba n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64Array# mba n1 s1 + !(# s3, r2 #) = readWord64Array# mba n2 s2 + !(# s4, r3 #) = readWord64Array# mba n3 s3 + !(# s5, r4 #) = readWord64Array# mba n4 s4 + in (# s5, Word256 (W64# r1) (W64# r2) (W64# r3) (W64# r4) #) + where (# n1, n2, n3, n4 #) = offset256_64 n + {-# INLINE primMbaURead #-} + primMbaUWrite mba n (Word256 (W64# w1) (W64# w2) (W64# w3) (W64# w4)) = primitive $ \s1 -> + let !s2 = writeWord64Array# mba n1 w1 s1 + !s3 = writeWord64Array# mba n2 w2 s2 + !s4 = writeWord64Array# mba n3 w3 s3 + in (# writeWord64Array# mba n4 w4 s4, () #) + where (# n1, n2, n3, n4 #) = offset256_64 n + {-# INLINE primMbaUWrite #-} + primAddrIndex addr n = Word256 (W64# (indexWord64OffAddr# addr n1)) (W64# (indexWord64OffAddr# addr n2)) + (W64# (indexWord64OffAddr# addr n3)) (W64# (indexWord64OffAddr# addr n4)) + where (# n1, n2, n3, n4 #) = offset256_64 n + {-# INLINE primAddrIndex #-} + primAddrRead addr n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64OffAddr# addr n1 s1 + !(# s3, r2 #) = readWord64OffAddr# addr n2 s2 + !(# s4, r3 #) = readWord64OffAddr# addr n3 s3 + !(# s5, r4 #) = readWord64OffAddr# addr n4 s4 + in (# s5, Word256 (W64# r1) (W64# r2) (W64# r3) (W64# r4) #) + where (# n1, n2, n3, n4 #) = offset256_64 n + {-# INLINE primAddrRead #-} + primAddrWrite addr n (Word256 (W64# w1) (W64# w2) (W64# w3) (W64# w4)) = primitive $ \s1 -> + let !s2 = writeWord64OffAddr# addr n1 w1 s1 + !s3 = writeWord64OffAddr# addr n2 w2 s2 + !s4 = writeWord64OffAddr# addr n3 w3 s3 + in (# writeWord64OffAddr# addr n4 w4 s4, () #) + where (# n1, n2, n3, n4 #) = offset256_64 n + {-# INLINE primAddrWrite #-} +instance PrimType Int8 where + type PrimSize Int8 = 1 + primSizeInBytes _ = CountOf 1 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 0 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset (I# n)) = I8# (indexInt8Array# ba n) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt8Array# mba n s1 in (# s2, I8# r #) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset (I# n)) (I8# w) = primitive $ \s1 -> (# writeInt8Array# mba n w s1, () #) + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset (I# n)) = I8# (indexInt8OffAddr# addr n) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt8OffAddr# addr n s1 in (# s2, I8# r #) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset (I# n)) (I8# w) = primitive $ \s1 -> (# writeInt8OffAddr# addr n w s1, () #) + {-# INLINE primAddrWrite #-} +instance PrimType Int16 where + type PrimSize Int16 = 2 + primSizeInBytes _ = CountOf 2 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 1 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset (I# n)) = I16# (indexInt16Array# ba n) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt16Array# mba n s1 in (# s2, I16# r #) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset (I# n)) (I16# w) = primitive $ \s1 -> (# writeInt16Array# mba n w s1, () #) + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset (I# n)) = I16# (indexInt16OffAddr# addr n) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt16OffAddr# addr n s1 in (# s2, I16# r #) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset (I# n)) (I16# w) = primitive $ \s1 -> (# writeInt16OffAddr# addr n w s1, () #) + {-# INLINE primAddrWrite #-} +instance PrimType Int32 where + type PrimSize Int32 = 4 + primSizeInBytes _ = CountOf 4 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 2 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset (I# n)) = I32# (indexInt32Array# ba n) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt32Array# mba n s1 in (# s2, I32# r #) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset (I# n)) (I32# w) = primitive $ \s1 -> (# writeInt32Array# mba n w s1, () #) + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset (I# n)) = I32# (indexInt32OffAddr# addr n) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt32OffAddr# addr n s1 in (# s2, I32# r #) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset (I# n)) (I32# w) = primitive $ \s1 -> (# writeInt32OffAddr# addr n w s1, () #) + {-# INLINE primAddrWrite #-} +instance PrimType Int64 where + type PrimSize Int64 = 8 + primSizeInBytes _ = CountOf 8 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 3 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset (I# n)) = I64# (indexInt64Array# ba n) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt64Array# mba n s1 in (# s2, I64# r #) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset (I# n)) (I64# w) = primitive $ \s1 -> (# writeInt64Array# mba n w s1, () #) + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset (I# n)) = I64# (indexInt64OffAddr# addr n) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt64OffAddr# addr n s1 in (# s2, I64# r #) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset (I# n)) (I64# w) = primitive $ \s1 -> (# writeInt64OffAddr# addr n w s1, () #) + {-# INLINE primAddrWrite #-} + +instance PrimType Float where + type PrimSize Float = 4 + primSizeInBytes _ = CountOf 4 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 2 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset (I# n)) = F# (indexFloatArray# ba n) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readFloatArray# mba n s1 in (# s2, F# r #) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset (I# n)) (F# w) = primitive $ \s1 -> (# writeFloatArray# mba n w s1, () #) + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset (I# n)) = F# (indexFloatOffAddr# addr n) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readFloatOffAddr# addr n s1 in (# s2, F# r #) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset (I# n)) (F# w) = primitive $ \s1 -> (# writeFloatOffAddr# addr n w s1, () #) + {-# INLINE primAddrWrite #-} +instance PrimType Double where + type PrimSize Double = 8 + primSizeInBytes _ = CountOf 8 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 3 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset (I# n)) = D# (indexDoubleArray# ba n) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readDoubleArray# mba n s1 in (# s2, D# r #) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset (I# n)) (D# w) = primitive $ \s1 -> (# writeDoubleArray# mba n w s1, () #) + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset (I# n)) = D# (indexDoubleOffAddr# addr n) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readDoubleOffAddr# addr n s1 in (# s2, D# r #) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset (I# n)) (D# w) = primitive $ \s1 -> (# writeDoubleOffAddr# addr n w s1, () #) + {-# INLINE primAddrWrite #-} + +instance PrimType Char where + type PrimSize Char = 4 + primSizeInBytes _ = CountOf 4 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 2 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset (I# n)) = C# (indexWideCharArray# ba n) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWideCharArray# mba n s1 in (# s2, C# r #) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset (I# n)) (C# w) = primitive $ \s1 -> (# writeWideCharArray# mba n w s1, () #) + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset (I# n)) = C# (indexWideCharOffAddr# addr n) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWideCharOffAddr# addr n s1 in (# s2, C# r #) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset (I# n)) (C# w) = primitive $ \s1 -> (# writeWideCharOffAddr# addr n w s1, () #) + {-# INLINE primAddrWrite #-} + +instance PrimType CChar where + type PrimSize CChar = 1 + primSizeInBytes _ = CountOf 1 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 0 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset n) = CChar (primBaUIndex ba (Offset n)) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset n) = CChar <$> primMbaURead mba (Offset n) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset n) (CChar int8) = primMbaUWrite mba (Offset n) int8 + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset n) = CChar $ primAddrIndex addr (Offset n) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset n) = CChar <$> primAddrRead addr (Offset n) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset n) (CChar int8) = primAddrWrite addr (Offset n) int8 + {-# INLINE primAddrWrite #-} +instance PrimType CUChar where + type PrimSize CUChar = 1 + primSizeInBytes _ = CountOf 1 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 0 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset n) = CUChar (primBaUIndex ba (Offset n :: Offset Word8)) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset n) = CUChar <$> primMbaURead mba (Offset n :: Offset Word8) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset n) (CUChar w8) = primMbaUWrite mba (Offset n) w8 + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset n) = CUChar $ primAddrIndex addr (Offset n :: Offset Word8) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset n) = CUChar <$> primAddrRead addr (Offset n :: Offset Word8) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset n) (CUChar w8) = primAddrWrite addr (Offset n) w8 + {-# INLINE primAddrWrite #-} + +instance PrimType Char7 where + type PrimSize Char7 = 1 + primSizeInBytes _ = CountOf 1 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 0 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset n) = Char7 (primBaUIndex ba (Offset n :: Offset Word8)) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset n) = Char7 <$> primMbaURead mba (Offset n :: Offset Word8) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset n) (Char7 w8) = primMbaUWrite mba (Offset n) w8 + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset n) = Char7 $ primAddrIndex addr (Offset n :: Offset Word8) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset n) = Char7 <$> primAddrRead addr (Offset n :: Offset Word8) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset n) (Char7 w8) = primAddrWrite addr (Offset n) w8 + {-# INLINE primAddrWrite #-} + +instance PrimType a => PrimType (LE a) where + type PrimSize (LE a) = PrimSize a + primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy a) + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy a) + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset a) = LE $ primBaUIndex ba (Offset a) + {-# INLINE primBaUIndex #-} + primMbaURead ba (Offset a) = LE <$> primMbaURead ba (Offset a) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset a) (LE w) = primMbaUWrite mba (Offset a) w + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset a) = LE $ primAddrIndex addr (Offset a) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset a) = LE <$> primAddrRead addr (Offset a) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset a) (LE w) = primAddrWrite addr (Offset a) w + {-# INLINE primAddrWrite #-} +instance PrimType a => PrimType (BE a) where + type PrimSize (BE a) = PrimSize a + primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy a) + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy a) + {-# INLINE primShiftToBytes #-} + primBaUIndex ba (Offset a) = BE $ primBaUIndex ba (Offset a) + {-# INLINE primBaUIndex #-} + primMbaURead ba (Offset a) = BE <$> primMbaURead ba (Offset a) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset a) (BE w) = primMbaUWrite mba (Offset a) w + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset a) = BE $ primAddrIndex addr (Offset a) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset a) = BE <$> primAddrRead addr (Offset a) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset a) (BE w) = primAddrWrite addr (Offset a) w + {-# INLINE primAddrWrite #-} + +-- | A constraint class for serializable type that have an unique +-- memory compare representation +-- +-- e.g. Float and Double have -0.0 and 0.0 which are Eq individual, +-- yet have a different memory representation which doesn't allow +-- for memcmp operation +class PrimMemoryComparable ty where + +instance PrimMemoryComparable Int where +instance PrimMemoryComparable Word where +instance PrimMemoryComparable Word8 where +instance PrimMemoryComparable Word16 where +instance PrimMemoryComparable Word32 where +instance PrimMemoryComparable Word64 where +instance PrimMemoryComparable Word128 where +instance PrimMemoryComparable Word256 where +instance PrimMemoryComparable Int8 where +instance PrimMemoryComparable Int16 where +instance PrimMemoryComparable Int32 where +instance PrimMemoryComparable Int64 where +instance PrimMemoryComparable Char where +instance PrimMemoryComparable CChar where +instance PrimMemoryComparable CUChar where +instance PrimMemoryComparable a => PrimMemoryComparable (LE a) where +instance PrimMemoryComparable a => PrimMemoryComparable (BE a) where + +offset128_64 :: Offset Word128 -> (# Int#, Int# #) +offset128_64 (Offset (I# i)) = (# n , n +# 1# #) + where !n = uncheckedIShiftL# i 1# + +offset256_64 :: Offset Word256 -> (# Int#, Int#, Int#, Int# #) +offset256_64 (Offset (I# i)) = (# n , n +# 1#, n +# 2#, n +# 3# #) + where !n = uncheckedIShiftL# i 2# + +-- | Cast a CountOf linked to type A (CountOf A) to a CountOf linked to type B (CountOf B) +sizeRecast :: forall a b . (PrimType a, PrimType b) => CountOf a -> CountOf b +sizeRecast sz = CountOf (bytes `Prelude.quot` szB) + where !szA = primSizeInBytes (Proxy :: Proxy a) + !(CountOf szB) = primSizeInBytes (Proxy :: Proxy b) + !(CountOf bytes) = sizeOfE szA sz +{-# INLINE [1] sizeRecast #-} +{-# RULES "sizeRecast from Word8" [2] forall a . sizeRecast a = sizeRecastBytes a #-} + +sizeRecastBytes :: forall b . PrimType b => CountOf Word8 -> CountOf b +sizeRecastBytes (CountOf w) = CountOf (w `Prelude.quot` szB) + where !(CountOf szB) = primSizeInBytes (Proxy :: Proxy b) +{-# INLINE [1] sizeRecastBytes #-} + +sizeInBytes :: forall a . PrimType a => CountOf a -> CountOf Word8 +sizeInBytes sz = sizeOfE (primSizeInBytes (Proxy :: Proxy a)) sz + +offsetInBytes :: forall a . PrimType a => Offset a -> Offset Word8 +offsetInBytes ofs = offsetShiftL (primShiftToBytes (Proxy :: Proxy a)) ofs +{-# INLINE [2] offsetInBytes #-} +{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word64 -> Offset Word8 #-} +{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word32 -> Offset Word8 #-} +{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word16 -> Offset Word8 #-} +{-# RULES "offsetInBytes Bytes" [3] forall x . offsetInBytes x = x #-} + +offsetInElements :: forall a . PrimType a => Offset Word8 -> Offset a +offsetInElements ofs = offsetShiftR (primShiftToBytes (Proxy :: Proxy a)) ofs +{-# INLINE [2] offsetInElements #-} +{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word64 -> Offset Word8 #-} +{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word32 -> Offset Word8 #-} +{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word16 -> Offset Word8 #-} +{-# RULES "offsetInElements Bytes" [3] forall x . offsetInElements x = x #-} + +primOffsetRecast :: forall a b . (PrimType a, PrimType b) => Offset a -> Offset b +primOffsetRecast !ofs = + let !(Offset bytes) = offsetOfE szA ofs + in Offset (bytes `Prelude.quot` szB) + where + !szA = primSizeInBytes (Proxy :: Proxy a) + !(CountOf szB) = primSizeInBytes (Proxy :: Proxy b) +{-# INLINE [1] primOffsetRecast #-} +{-# RULES "primOffsetRecast W8" [3] forall a . primOffsetRecast a = primOffsetRecastBytes a #-} + +offsetIsAligned :: forall a . PrimType a => Proxy a -> Offset Word8 -> Bool +offsetIsAligned _ (Offset ofs) = (ofs .&. mask) == 0 + where (CountOf sz) = primSizeInBytes (Proxy :: Proxy a) + mask = sz - 1 +{-# INLINE [1] offsetIsAligned #-} +{-# SPECIALIZE [3] offsetIsAligned :: Proxy Word64 -> Offset Word8 -> Bool #-} +{-# RULES "offsetInAligned Bytes" [3] forall (prx :: Proxy Word8) x . offsetIsAligned prx x = True #-} + +primOffsetRecastBytes :: forall b . PrimType b => Offset Word8 -> Offset b +primOffsetRecastBytes (Offset 0) = Offset 0 +primOffsetRecastBytes (Offset o) = Offset (szA `Prelude.quot` o) + where !(CountOf szA) = primSizeInBytes (Proxy :: Proxy b) +{-# INLINE [1] primOffsetRecastBytes #-} + +primOffsetOfE :: forall a . PrimType a => Offset a -> Offset Word8 +primOffsetOfE = offsetInBytes +{-# DEPRECATED primOffsetOfE "use offsetInBytes" #-} + +primWordGetByteAndShift :: Word# -> (# Word#, Word# #) +primWordGetByteAndShift w = (# and# w 0xff##, uncheckedShiftRL# w 8# #) +{-# INLINE primWordGetByteAndShift #-} + +#if WORD_SIZE_IN_BITS == 64 +primWord64GetByteAndShift :: Word# -> (# Word#, Word# #) +primWord64GetByteAndShift = primWord64GetByteAndShift + +primWord64GetHiLo :: Word# -> (# Word#, Word# #) +primWord64GetHiLo w = (# uncheckedShiftRL# w 32# , and# w 0xffffffff## #) +#else +primWord64GetByteAndShift :: Word64# -> (# Word#, Word64# #) +primWord64GetByteAndShift w = (# and# (word64ToWord# w) 0xff##, uncheckedShiftRL64# w 8# #) + +primWord64GetHiLo :: Word64# -> (# Word#, Word# #) +primWord64GetHiLo w = (# word64ToWord# (uncheckedShiftRL64# w 32#), word64ToWord# w #) +#endif +{-# INLINE primWord64GetByteAndShift #-} diff --git a/bundled/Basement/Runtime.hs b/bundled/Basement/Runtime.hs new file mode 100644 index 0000000..9698786 --- /dev/null +++ b/bundled/Basement/Runtime.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Runtime +-- License : BSD-style +-- Maintainer : foundation +-- +-- Global configuration environment +module Basement.Runtime + where + +import Basement.Compat.Base +import Basement.Types.OffsetSize +import System.Environment +import System.IO.Unsafe (unsafePerformIO) +import Text.Read (readMaybe) + +-- | Defines the maximum size in bytes of unpinned arrays. +-- +-- You can change this value by setting the environment variable +-- @HS_FOUNDATION_UARRAY_UNPINNED_MAX@ to an unsigned integer number. +-- +-- Note: We use 'unsafePerformIO' here. If the environment variable +-- changes during runtime and the runtime system decides to recompute +-- this value, referential transparency is violated (like the First +-- Order violated the Galactic Concordance!). +-- +-- TODO The default value of 1024 bytes is arbitrarily chosen for now. +unsafeUArrayUnpinnedMaxSize :: CountOf Word8 +unsafeUArrayUnpinnedMaxSize = unsafePerformIO $ do + maxSize <- (>>= readMaybe) <$> lookupEnv "HS_FOUNDATION_UARRAY_UNPINNED_MAX" + pure $ maybe (CountOf 1024) CountOf maxSize +{-# NOINLINE unsafeUArrayUnpinnedMaxSize #-} diff --git a/bundled/Basement/Show.hs b/bundled/Basement/Show.hs new file mode 100644 index 0000000..e478ef2 --- /dev/null +++ b/bundled/Basement/Show.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Basement.Show + where + +import qualified Prelude +import Basement.Compat.Base +import Basement.UTF8.Base (String) + +-- | Use the Show class to create a String. +-- +-- Note that this is not efficient, since +-- an intermediate [Char] is going to be +-- created before turning into a real String. +show :: Prelude.Show a => a -> String +show = fromList . Prelude.show diff --git a/bundled/Basement/Sized/Block.hs b/bundled/Basement/Sized/Block.hs new file mode 100644 index 0000000..01bd880 --- /dev/null +++ b/bundled/Basement/Sized/Block.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Sized.Block +-- License : BSD-style +-- Maintainer : Haskell Foundation +-- +-- A Nat-sized version of Block +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE NoStarIsType #-} +#endif + +module Basement.Sized.Block + ( BlockN + , MutableBlockN + , length + , lengthBytes + , toBlockN + , toBlock + , new + , newPinned + , singleton + , replicate + , thaw + , freeze + , index + , indexStatic + , map + , foldl' + , foldr + , cons + , snoc + , elem + , sub + , uncons + , unsnoc + , splitAt + , all + , any + , find + , reverse + , sortBy + , intersperse + , withPtr + , withMutablePtr + , withMutablePtrHint + , cast + , mutableCast + ) where + +import Data.Proxy (Proxy(..)) +import Basement.Compat.Base +import Basement.Numerical.Additive (scale) +import Basement.Block (Block, MutableBlock(..), unsafeIndex) +import qualified Basement.Block as B +import qualified Basement.Block.Base as B +import Basement.Monad (PrimMonad, PrimState) +import Basement.Nat +import Basement.Types.OffsetSize +import Basement.NormalForm +import Basement.PrimType (PrimType, PrimSize, primSizeInBytes) + +-- | Sized version of 'Block' +-- +newtype BlockN (n :: Nat) a = BlockN { unBlock :: Block a } + deriving (NormalForm, Eq, Show, Data, Ord) + +newtype MutableBlockN (n :: Nat) ty st = MutableBlockN { unMBlock :: MutableBlock ty st } + +toBlockN :: forall n ty . (PrimType ty, KnownNat n, Countable ty n) => Block ty -> Maybe (BlockN n ty) +toBlockN b + | expected == B.length b = Just (BlockN b) + | otherwise = Nothing + where + expected = toCount @n + +length :: forall n ty + . (KnownNat n, Countable ty n) + => BlockN n ty + -> CountOf ty +length _ = toCount @n + +lengthBytes :: forall n ty + . PrimType ty + => BlockN n ty + -> CountOf Word8 +lengthBytes = B.lengthBytes . unBlock + +toBlock :: BlockN n ty -> Block ty +toBlock = unBlock + +cast :: forall n m a b + . ( PrimType a, PrimType b + , KnownNat n, KnownNat m + , ((PrimSize b) * m) ~ ((PrimSize a) * n) + ) + => BlockN n a + -> BlockN m b +cast (BlockN b) = BlockN (B.unsafeCast b) + +mutableCast :: forall n m a b st + . ( PrimType a, PrimType b + , KnownNat n, KnownNat m + , ((PrimSize b) * m) ~ ((PrimSize a) * n) + ) + => MutableBlockN n a st + -> MutableBlockN m b st +mutableCast (MutableBlockN b) = MutableBlockN (B.unsafeRecast b) + +-- | Create a new unpinned mutable block of a specific N size of 'ty' elements +-- +-- If the size exceeds a GHC-defined threshold, then the memory will be +-- pinned. To be certain about pinning status with small size, use 'newPinned' +new :: forall n ty prim + . (PrimType ty, KnownNat n, Countable ty n, PrimMonad prim) + => prim (MutableBlockN n ty (PrimState prim)) +new = MutableBlockN <$> B.new (toCount @n) + +-- | Create a new pinned mutable block of a specific N size of 'ty' elements +newPinned :: forall n ty prim + . (PrimType ty, KnownNat n, Countable ty n, PrimMonad prim) + => prim (MutableBlockN n ty (PrimState prim)) +newPinned = MutableBlockN <$> B.newPinned (toCount @n) + +singleton :: PrimType ty => ty -> BlockN 1 ty +singleton a = BlockN (B.singleton a) + +replicate :: forall n ty . (KnownNat n, Countable ty n, PrimType ty) => ty -> BlockN n ty +replicate a = BlockN (B.replicate (toCount @n) a) + +thaw :: (KnownNat n, PrimMonad prim, PrimType ty) => BlockN n ty -> prim (MutableBlockN n ty (PrimState prim)) +thaw b = MutableBlockN <$> B.thaw (unBlock b) + +freeze :: (PrimMonad prim, PrimType ty, Countable ty n) => MutableBlockN n ty (PrimState prim) -> prim (BlockN n ty) +freeze b = BlockN <$> B.freeze (unMBlock b) + +indexStatic :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, PrimType ty, Offsetable ty i) => BlockN n ty -> ty +indexStatic b = unsafeIndex (unBlock b) (toOffset @i) + +index :: forall i n ty . PrimType ty => BlockN n ty -> Offset ty -> ty +index b ofs = B.index (unBlock b) ofs + +map :: (PrimType a, PrimType b) => (a -> b) -> BlockN n a -> BlockN n b +map f b = BlockN (B.map f (unBlock b)) + +foldl' :: PrimType ty => (a -> ty -> a) -> a -> BlockN n ty -> a +foldl' f acc b = B.foldl' f acc (unBlock b) + +foldr :: PrimType ty => (ty -> a -> a) -> a -> BlockN n ty -> a +foldr f acc b = B.foldr f acc (unBlock b) + +cons :: PrimType ty => ty -> BlockN n ty -> BlockN (n+1) ty +cons e = BlockN . B.cons e . unBlock + +snoc :: PrimType ty => BlockN n ty -> ty -> BlockN (n+1) ty +snoc b = BlockN . B.snoc (unBlock b) + +sub :: forall i j n ty + . ( (i <=? n) ~ 'True + , (j <=? n) ~ 'True + , (i <=? j) ~ 'True + , PrimType ty + , KnownNat i + , KnownNat j + , Offsetable ty i + , Offsetable ty j ) + => BlockN n ty + -> BlockN (j-i) ty +sub block = BlockN (B.sub (unBlock block) (toOffset @i) (toOffset @j)) + +uncons :: forall n ty . (CmpNat 0 n ~ 'LT, PrimType ty, KnownNat n, Offsetable ty n) + => BlockN n ty + -> (ty, BlockN (n-1) ty) +uncons b = (indexStatic @0 b, BlockN (B.sub (unBlock b) 1 (toOffset @n))) + +unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, PrimType ty, Offsetable ty n) + => BlockN n ty + -> (BlockN (n-1) ty, ty) +unsnoc b = + ( BlockN (B.sub (unBlock b) 0 (toOffset @n `offsetSub` 1)) + , unsafeIndex (unBlock b) (toOffset @n `offsetSub` 1)) + +splitAt :: forall i n ty . (CmpNat i n ~ 'LT, PrimType ty, KnownNat i, Countable ty i) => BlockN n ty -> (BlockN i ty, BlockN (n-i) ty) +splitAt b = + let (left, right) = B.splitAt (toCount @i) (unBlock b) + in (BlockN left, BlockN right) + +elem :: PrimType ty => ty -> BlockN n ty -> Bool +elem e b = B.elem e (unBlock b) + +all :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Bool +all p b = B.all p (unBlock b) + +any :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Bool +any p b = B.any p (unBlock b) + +find :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Maybe ty +find p b = B.find p (unBlock b) + +reverse :: PrimType ty => BlockN n ty -> BlockN n ty +reverse = BlockN . B.reverse . unBlock + +sortBy :: PrimType ty => (ty -> ty -> Ordering) -> BlockN n ty -> BlockN n ty +sortBy f b = BlockN (B.sortBy f (unBlock b)) + +intersperse :: (CmpNat n 1 ~ 'GT, PrimType ty) => ty -> BlockN n ty -> BlockN (n+n-1) ty +intersperse sep b = BlockN (B.intersperse sep (unBlock b)) + +toCount :: forall n ty . (KnownNat n, Countable ty n) => CountOf ty +toCount = natValCountOf (Proxy @n) + +toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty +toOffset = natValOffset (Proxy @n) + +-- | Get a Ptr pointing to the data in the Block. +-- +-- Since a Block is immutable, this Ptr shouldn't be +-- to use to modify the contents +-- +-- If the Block is pinned, then its address is returned as is, +-- however if it's unpinned, a pinned copy of the Block is made +-- before getting the address. +withPtr :: (PrimMonad prim, KnownNat n) + => BlockN n ty + -> (Ptr ty -> prim a) + -> prim a +withPtr b = B.withPtr (unBlock b) + +-- | Create a pointer on the beginning of the MutableBlock +-- and call a function 'f'. +-- +-- The mutable block can be mutated by the 'f' function +-- and the change will be reflected in the mutable block +-- +-- If the mutable block is unpinned, a trampoline buffer +-- is created and the data is only copied when 'f' return. +-- +-- it is all-in-all highly inefficient as this cause 2 copies +withMutablePtr :: (PrimMonad prim, KnownNat n) + => MutableBlockN n ty (PrimState prim) + -> (Ptr ty -> prim a) + -> prim a +withMutablePtr mb = B.withMutablePtr (unMBlock mb) + +-- | Same as 'withMutablePtr' but allow to specify 2 optimisations +-- which is only useful when the MutableBlock is unpinned and need +-- a pinned trampoline to be called safely. +-- +-- If skipCopy is True, then the first copy which happen before +-- the call to 'f', is skipped. The Ptr is now effectively +-- pointing to uninitialized data in a new mutable Block. +-- +-- If skipCopyBack is True, then the second copy which happen after +-- the call to 'f', is skipped. Then effectively in the case of a +-- trampoline being used the memory changed by 'f' will not +-- be reflected in the original Mutable Block. +-- +-- If using the wrong parameters, it will lead to difficult to +-- debug issue of corrupted buffer which only present themselves +-- with certain Mutable Block that happened to have been allocated +-- unpinned. +-- +-- If unsure use 'withMutablePtr', which default to *not* skip +-- any copy. +withMutablePtrHint :: forall n ty prim a . (PrimMonad prim, KnownNat n) + => Bool -- ^ hint that the buffer doesn't need to have the same value as the mutable block when calling f + -> Bool -- ^ hint that the buffer is not supposed to be modified by call of f + -> MutableBlockN n ty (PrimState prim) + -> (Ptr ty -> prim a) + -> prim a +withMutablePtrHint skipCopy skipCopyBack (MutableBlockN mb) f = + B.withMutablePtrHint skipCopy skipCopyBack mb f diff --git a/bundled/Basement/Sized/List.hs b/bundled/Basement/Sized/List.hs new file mode 100644 index 0000000..b963887 --- /dev/null +++ b/bundled/Basement/Sized/List.hs @@ -0,0 +1,389 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Sized.List +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- A Nat-sized list abstraction +-- +-- Using this module is limited to GHC 7.10 and above. +-- +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +module Basement.Sized.List + ( ListN + , toListN + , toListN_ + , unListN + , length + , create + , createFrom + , empty + , singleton + , uncons + , cons + , unsnoc + , snoc + , index + , indexStatic + , updateAt + , map + , mapi + , elem + , foldl + , foldl' + , foldl1' + , scanl' + , scanl1' + , foldr + , foldr1 + , reverse + , append + , minimum + , maximum + , head + , tail + , init + , take + , drop + , splitAt + , zip, zip3, zip4, zip5 + , unzip + , zipWith, zipWith3, zipWith4, zipWith5 + , replicate + -- * Applicative And Monadic + , replicateM + , sequence + , sequence_ + , mapM + , mapM_ + ) where + +import Data.Proxy +import qualified Data.List +import Basement.Compat.Base +import Basement.Compat.CallStack +import Basement.Compat.Natural +import Basement.Nat +import Basement.NormalForm +import Basement.Numerical.Additive +import Basement.Numerical.Subtractive +import Basement.Types.OffsetSize +import Basement.Compat.ExtList ((!!)) +import qualified Prelude +import qualified Control.Monad as M (replicateM, mapM, mapM_, sequence, sequence_) + +impossible :: HasCallStack => a +impossible = error "ListN: internal error: the impossible happened" + +-- | A Typed-level sized List equivalent to [a] +newtype ListN (n :: Nat) a = ListN { unListN :: [a] } + deriving (Eq,Ord,Typeable,Generic) + +instance Show a => Show (ListN n a) where + show (ListN l) = show l + +instance NormalForm a => NormalForm (ListN n a) where + toNormalForm (ListN l) = toNormalForm l + +-- | Try to create a ListN from a List, succeeding if the length is correct +toListN :: forall (n :: Nat) a . (KnownNat n, NatWithinBound Int n) => [a] -> Maybe (ListN n a) +toListN l + | expected == Prelude.fromIntegral (Prelude.length l) = Just (ListN l) + | otherwise = Nothing + where + expected = natValInt (Proxy :: Proxy n) + +-- | Create a ListN from a List, expecting a given length +-- +-- If this list contains more or less than the expected length of the resulting type, +-- then an asynchronous error is raised. use 'toListN' for a more friendly functions +toListN_ :: forall n a . (HasCallStack, NatWithinBound Int n, KnownNat n) => [a] -> ListN n a +toListN_ l + | expected == got = ListN l + | otherwise = error ("toListN_: expecting list of " <> show expected <> " elements, got " <> show got <> " elements") + where + expected = natValInt (Proxy :: Proxy n) + got = Prelude.length l + +-- | performs a monadic action n times, gathering the results in a List of size n. +replicateM :: forall (n :: Nat) m a . (NatWithinBound Int n, Monad m, KnownNat n) => m a -> m (ListN n a) +replicateM action = ListN <$> M.replicateM (Prelude.fromIntegral $ natVal (Proxy :: Proxy n)) action + +-- | Evaluate each monadic action in the list sequentially, and collect the results. +sequence :: Monad m => ListN n (m a) -> m (ListN n a) +sequence (ListN l) = ListN <$> M.sequence l + +-- | Evaluate each monadic action in the list sequentially, and ignore the results. +sequence_ :: Monad m => ListN n (m a) -> m () +sequence_ (ListN l) = M.sequence_ l + +-- | Map each element of a List to a monadic action, evaluate these +-- actions sequentially and collect the results +mapM :: Monad m => (a -> m b) -> ListN n a -> m (ListN n b) +mapM f (ListN l) = ListN <$> M.mapM f l + +-- | Map each element of a List to a monadic action, evaluate these +-- actions sequentially and ignore the results +mapM_ :: Monad m => (a -> m b) -> ListN n a -> m () +mapM_ f (ListN l) = M.mapM_ f l + +-- | Create a list of n elements where each element is the element in argument +replicate :: forall (n :: Nat) a . (NatWithinBound Int n, KnownNat n) => a -> ListN n a +replicate a = ListN $ Prelude.replicate (Prelude.fromIntegral $ natVal (Proxy :: Proxy n)) a + +-- | Decompose a list into its head and tail. +uncons :: (1 <= n) => ListN n a -> (a, ListN (n-1) a) +uncons (ListN (x:xs)) = (x, ListN xs) +uncons _ = impossible + +-- | prepend an element to the list +cons :: a -> ListN n a -> ListN (n+1) a +cons a (ListN l) = ListN (a : l) + +-- | Decompose a list into its first elements and the last. +unsnoc :: (1 <= n) => ListN n a -> (ListN (n-1) a, a) +unsnoc (ListN l) = (ListN $ Data.List.init l, Data.List.last l) + +-- | append an element to the list +snoc :: ListN n a -> a -> ListN (n+1) a +snoc (ListN l) a = ListN (l Prelude.++ [a]) + +-- | Create an empty list of a +empty :: ListN 0 a +empty = ListN [] + +-- | Get the length of a list +length :: forall a (n :: Nat) . (KnownNat n, NatWithinBound Int n) => ListN n a -> CountOf a +length _ = CountOf $ natValInt (Proxy :: Proxy n) + +-- | Create a new list of size n, repeately calling f from 0 to n-1 +create :: forall a (n :: Nat) . KnownNat n => (Natural -> a) -> ListN n a +create f = ListN $ Prelude.map (f . Prelude.fromIntegral) [0..(len-1)] + where + len = natVal (Proxy :: Proxy n) + +-- | Same as create but apply an offset +createFrom :: forall a (n :: Nat) (start :: Nat) . (KnownNat n, KnownNat start) + => Proxy start -> (Natural -> a) -> ListN n a +createFrom p f = ListN $ Prelude.map (f . Prelude.fromIntegral) [idx..(idx+len-1)] + where + len = natVal (Proxy :: Proxy n) + idx = natVal p + +-- | create a list of 1 element +singleton :: a -> ListN 1 a +singleton a = ListN [a] + +-- | Check if a list contains the element a +elem :: Eq a => a -> ListN n a -> Bool +elem a (ListN l) = Prelude.elem a l + +-- | Append 2 list together returning the new list +append :: ListN n a -> ListN m a -> ListN (n+m) a +append (ListN l1) (ListN l2) = ListN (l1 <> l2) + +-- | Get the maximum element of a list +maximum :: (Ord a, 1 <= n) => ListN n a -> a +maximum (ListN l) = Prelude.maximum l + +-- | Get the minimum element of a list +minimum :: (Ord a, 1 <= n) => ListN n a -> a +minimum (ListN l) = Prelude.minimum l + +-- | Get the head element of a list +head :: (1 <= n) => ListN n a -> a +head (ListN (x:_)) = x +head _ = impossible + +-- | Get the tail of a list +tail :: (1 <= n) => ListN n a -> ListN (n-1) a +tail (ListN (_:xs)) = ListN xs +tail _ = impossible + +-- | Get the list with the last element missing +init :: (1 <= n) => ListN n a -> ListN (n-1) a +init (ListN l) = ListN $ Data.List.init l + +-- | Take m elements from the beggining of the list. +-- +-- The number of elements need to be less or equal to the list in argument +take :: forall a (m :: Nat) (n :: Nat) . (KnownNat m, NatWithinBound Int m, m <= n) => ListN n a -> ListN m a +take (ListN l) = ListN (Prelude.take n l) + where n = natValInt (Proxy :: Proxy m) + +-- | Drop elements from a list keeping the m remaining elements +drop :: forall a d (m :: Nat) (n :: Nat) . (KnownNat d, NatWithinBound Int d, (n - m) ~ d, m <= n) => ListN n a -> ListN m a +drop (ListN l) = ListN (Prelude.drop n l) + where n = natValInt (Proxy :: Proxy d) + +-- | Split a list into two, returning 2 lists +splitAt :: forall a d (m :: Nat) (n :: Nat) . (KnownNat d, NatWithinBound Int d, (n - m) ~ d, m <= n) => ListN n a -> (ListN m a, ListN (n-m) a) +splitAt (ListN l) = let (l1, l2) = Prelude.splitAt n l in (ListN l1, ListN l2) + where n = natValInt (Proxy :: Proxy d) + +-- | Get the i'th elements +-- +-- This only works with TypeApplication: +-- +-- > indexStatic @1 (toListN_ [1,2,3] :: ListN 3 Int) +indexStatic :: forall i n a . (KnownNat i, CmpNat i n ~ 'LT, Offsetable a i) => ListN n a -> a +indexStatic (ListN l) = l !! (natValOffset (Proxy :: Proxy i)) + +-- | Get the i'the element +index :: ListN n ty -> Offset ty -> ty +index (ListN l) ofs = l !! ofs + +-- | Update the value in a list at a specific location +updateAt :: forall n a + . Offset a + -> (a -> a) + -> ListN n a + -> ListN n a +updateAt o f (ListN l) = ListN (doUpdate 0 l) + where doUpdate _ [] = [] + doUpdate i (x:xs) + | i == o = f x : xs + | otherwise = x : doUpdate (i+1) xs + +-- | Map all elements in a list +map :: (a -> b) -> ListN n a -> ListN n b +map f (ListN l) = ListN (Prelude.map f l) + +-- | Map all elements in a list with an additional index +mapi :: (Natural -> a -> b) -> ListN n a -> ListN n b +mapi f (ListN l) = ListN . loop 0 $ l + where loop _ [] = [] + loop i (x:xs) = f i x : loop (i+1) xs + +-- | Fold all elements from left +foldl :: (b -> a -> b) -> b -> ListN n a -> b +foldl f acc (ListN l) = Prelude.foldl f acc l + +-- | Fold all elements from left strictly +foldl' :: (b -> a -> b) -> b -> ListN n a -> b +foldl' f acc (ListN l) = Data.List.foldl' f acc l + +-- | Fold all elements from left strictly with a first element +-- as the accumulator +foldl1' :: (1 <= n) => (a -> a -> a) -> ListN n a -> a +foldl1' f (ListN l) = Data.List.foldl1' f l + +-- | Fold all elements from right +foldr :: (a -> b -> b) -> b -> ListN n a -> b +foldr f acc (ListN l) = Prelude.foldr f acc l + +-- | Fold all elements from right assuming at least one element is in the list. +foldr1 :: (1 <= n) => (a -> a -> a) -> ListN n a -> a +foldr1 f (ListN l) = Prelude.foldr1 f l + +-- | 'scanl' is similar to 'foldl', but returns a list of successive +-- reduced values from the left +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +scanl' :: (b -> a -> b) -> b -> ListN n a -> ListN (n+1) b +scanl' f initialAcc (ListN start) = ListN (go initialAcc start) + where + go !acc l = acc : case l of + [] -> [] + (x:xs) -> go (f acc x) xs + +-- | 'scanl1' is a variant of 'scanl' that has no starting value argument: +-- +-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] +scanl1' :: (a -> a -> a) -> ListN n a -> ListN n a +scanl1' f (ListN l) = case l of + [] -> ListN [] + (x:xs) -> ListN $ Data.List.scanl' f x xs + +-- | Reverse a list +reverse :: ListN n a -> ListN n a +reverse (ListN l) = ListN (Prelude.reverse l) + +-- | Zip 2 lists of the same size, returning a new list of +-- the tuple of each elements +zip :: ListN n a -> ListN n b -> ListN n (a,b) +zip (ListN l1) (ListN l2) = ListN (Prelude.zip l1 l2) + +-- | Unzip a list of tuple, to 2 List of the deconstructed tuples +unzip :: ListN n (a,b) -> (ListN n a, ListN n b) +unzip l = (map fst l, map snd l) + +-- | Zip 3 lists of the same size +zip3 :: ListN n a -> ListN n b -> ListN n c -> ListN n (a,b,c) +zip3 (ListN x1) (ListN x2) (ListN x3) = ListN (loop x1 x2 x3) + where loop (l1:l1s) (l2:l2s) (l3:l3s) = (l1,l2,l3) : loop l1s l2s l3s + loop [] _ _ = [] + loop _ _ _ = impossible + +-- | Zip 4 lists of the same size +zip4 :: ListN n a -> ListN n b -> ListN n c -> ListN n d -> ListN n (a,b,c,d) +zip4 (ListN x1) (ListN x2) (ListN x3) (ListN x4) = ListN (loop x1 x2 x3 x4) + where loop (l1:l1s) (l2:l2s) (l3:l3s) (l4:l4s) = (l1,l2,l3,l4) : loop l1s l2s l3s l4s + loop [] _ _ _ = [] + loop _ _ _ _ = impossible + +-- | Zip 5 lists of the same size +zip5 :: ListN n a -> ListN n b -> ListN n c -> ListN n d -> ListN n e -> ListN n (a,b,c,d,e) +zip5 (ListN x1) (ListN x2) (ListN x3) (ListN x4) (ListN x5) = ListN (loop x1 x2 x3 x4 x5) + where loop (l1:l1s) (l2:l2s) (l3:l3s) (l4:l4s) (l5:l5s) = (l1,l2,l3,l4,l5) : loop l1s l2s l3s l4s l5s + loop [] _ _ _ _ = [] + loop _ _ _ _ _ = impossible + +-- | Zip 2 lists using a function +zipWith :: (a -> b -> x) -> ListN n a -> ListN n b -> ListN n x +zipWith f (ListN (v1:vs)) (ListN (w1:ws)) = ListN (f v1 w1 : unListN (zipWith f (ListN vs) (ListN ws))) +zipWith _ (ListN []) _ = ListN [] +zipWith _ _ _ = impossible + +-- | Zip 3 lists using a function +zipWith3 :: (a -> b -> c -> x) + -> ListN n a + -> ListN n b + -> ListN n c + -> ListN n x +zipWith3 f (ListN (v1:vs)) (ListN (w1:ws)) (ListN (x1:xs)) = + ListN (f v1 w1 x1 : unListN (zipWith3 f (ListN vs) (ListN ws) (ListN xs))) +zipWith3 _ (ListN []) _ _ = ListN [] +zipWith3 _ _ _ _ = impossible + +-- | Zip 4 lists using a function +zipWith4 :: (a -> b -> c -> d -> x) + -> ListN n a + -> ListN n b + -> ListN n c + -> ListN n d + -> ListN n x +zipWith4 f (ListN (v1:vs)) (ListN (w1:ws)) (ListN (x1:xs)) (ListN (y1:ys)) = + ListN (f v1 w1 x1 y1 : unListN (zipWith4 f (ListN vs) (ListN ws) (ListN xs) (ListN ys))) +zipWith4 _ (ListN []) _ _ _ = ListN [] +zipWith4 _ _ _ _ _ = impossible + +-- | Zip 5 lists using a function +zipWith5 :: (a -> b -> c -> d -> e -> x) + -> ListN n a + -> ListN n b + -> ListN n c + -> ListN n d + -> ListN n e + -> ListN n x +zipWith5 f (ListN (v1:vs)) (ListN (w1:ws)) (ListN (x1:xs)) (ListN (y1:ys)) (ListN (z1:zs)) = + ListN (f v1 w1 x1 y1 z1 : unListN (zipWith5 f (ListN vs) (ListN ws) (ListN xs) (ListN ys) (ListN zs))) +zipWith5 _ (ListN []) _ _ _ _ = ListN [] +zipWith5 _ _ _ _ _ _ = impossible diff --git a/bundled/Basement/Sized/UVect.hs b/bundled/Basement/Sized/UVect.hs new file mode 100644 index 0000000..ffab7eb --- /dev/null +++ b/bundled/Basement/Sized/UVect.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +module Basement.Sized.UVect + ( UVect + , MUVect + , unUVect + , toUVect + , empty + , singleton + , replicate + , thaw + , freeze + , index + , map + , foldl' + , foldr + , cons + , snoc + , elem + , sub + , uncons + , unsnoc + , splitAt + , all + , any + , find + , reverse + , sortBy + , intersperse + ) where + +import Basement.Compat.Base +import Basement.Nat +import Basement.NormalForm +import Basement.Types.OffsetSize +import Basement.Monad +import Basement.PrimType (PrimType) +import qualified Basement.UArray as A +import qualified Basement.UArray.Mutable as A hiding (sub) +import Data.Proxy + +newtype UVect (n :: Nat) a = UVect { unUVect :: A.UArray a } deriving (NormalForm, Eq, Show) +newtype MUVect (n :: Nat) ty st = MUVect { unMUVect :: A.MUArray ty st } + +toUVect :: forall n ty . (PrimType ty, KnownNat n, Countable ty n) => A.UArray ty -> Maybe (UVect n ty) +toUVect b + | expected == A.length b = Just (UVect b) + | otherwise = Nothing + where + expected = toCount @n + +empty :: PrimType ty => UVect 0 ty +empty = UVect mempty + +singleton :: PrimType ty => ty -> UVect 1 ty +singleton a = UVect (A.singleton a) + +create :: forall ty (n :: Nat) . (PrimType ty, Countable ty n, KnownNat n) => (Offset ty -> ty) -> UVect n ty +create f = UVect $ A.create sz f + where + sz = natValCountOf (Proxy :: Proxy n) + +replicate :: forall n ty . (KnownNat n, Countable ty n, PrimType ty) => ty -> UVect n ty +replicate a = UVect (A.replicate (toCount @n) a) + +thaw :: (KnownNat n, PrimMonad prim, PrimType ty) => UVect n ty -> prim (MUVect n ty (PrimState prim)) +thaw b = MUVect <$> A.thaw (unUVect b) + +freeze :: (PrimMonad prim, PrimType ty, Countable ty n) => MUVect n ty (PrimState prim) -> prim (UVect n ty) +freeze b = UVect <$> A.freeze (unMUVect b) + +write :: (PrimMonad prim, PrimType ty) => MUVect n ty (PrimState prim) -> Offset ty -> ty -> prim () +write (MUVect ma) ofs v = A.write ma ofs v + +read :: (PrimMonad prim, PrimType ty) => MUVect n ty (PrimState prim) -> Offset ty -> prim ty +read (MUVect ma) ofs = A.read ma ofs + +indexStatic :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, PrimType ty, Offsetable ty i) => UVect n ty -> ty +indexStatic b = A.unsafeIndex (unUVect b) (toOffset @i) + +index :: forall i n ty . PrimType ty => UVect n ty -> Offset ty -> ty +index b ofs = A.index (unUVect b) ofs + +map :: (PrimType a, PrimType b) => (a -> b) -> UVect n a -> UVect n b +map f b = UVect (A.map f (unUVect b)) + +foldl' :: PrimType ty => (a -> ty -> a) -> a -> UVect n ty -> a +foldl' f acc b = A.foldl' f acc (unUVect b) + +foldr :: PrimType ty => (ty -> a -> a) -> a -> UVect n ty -> a +foldr f acc b = A.foldr f acc (unUVect b) + +cons :: PrimType ty => ty -> UVect n ty -> UVect (n+1) ty +cons e = UVect . A.cons e . unUVect + +snoc :: PrimType ty => UVect n ty -> ty -> UVect (n+1) ty +snoc b = UVect . A.snoc (unUVect b) + +sub :: forall i j n ty + . ( (i <=? n) ~ 'True + , (j <=? n) ~ 'True + , (i <=? j) ~ 'True + , PrimType ty + , KnownNat i + , KnownNat j + , Offsetable ty i + , Offsetable ty j ) + => UVect n ty + -> UVect (j-i) ty +sub block = UVect (A.sub (unUVect block) (toOffset @i) (toOffset @j)) + +uncons :: forall n ty . (CmpNat 0 n ~ 'LT, PrimType ty, KnownNat n, Offsetable ty n) + => UVect n ty + -> (ty, UVect (n-1) ty) +uncons b = (indexStatic @0 b, UVect (A.sub (unUVect b) 1 (toOffset @n))) + +unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, PrimType ty, Offsetable ty n) + => UVect n ty + -> (UVect (n-1) ty, ty) +unsnoc b = + ( UVect (A.sub (unUVect b) 0 (toOffset @n `offsetSub` 1)) + , A.unsafeIndex (unUVect b) (toOffset @n `offsetSub` 1)) + +splitAt :: forall i n ty . (CmpNat i n ~ 'LT, PrimType ty, KnownNat i, Countable ty i) => UVect n ty -> (UVect i ty, UVect (n-i) ty) +splitAt b = + let (left, right) = A.splitAt (toCount @i) (unUVect b) + in (UVect left, UVect right) + +elem :: PrimType ty => ty -> UVect n ty -> Bool +elem e b = A.elem e (unUVect b) + +all :: PrimType ty => (ty -> Bool) -> UVect n ty -> Bool +all p b = A.all p (unUVect b) + +any :: PrimType ty => (ty -> Bool) -> UVect n ty -> Bool +any p b = A.any p (unUVect b) + +find :: PrimType ty => (ty -> Bool) -> UVect n ty -> Maybe ty +find p b = A.find p (unUVect b) + +reverse :: PrimType ty => UVect n ty -> UVect n ty +reverse = UVect . A.reverse . unUVect + +sortBy :: PrimType ty => (ty -> ty -> Ordering) -> UVect n ty -> UVect n ty +sortBy f b = UVect (A.sortBy f (unUVect b)) + +intersperse :: (CmpNat n 1 ~ 'GT, PrimType ty) => ty -> UVect n ty -> UVect (n+n-1) ty +intersperse sep b = UVect (A.intersperse sep (unUVect b)) + +toCount :: forall n ty . (KnownNat n, Countable ty n) => CountOf ty +toCount = natValCountOf (Proxy @n) + +toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty +toOffset = natValOffset (Proxy @n) diff --git a/bundled/Basement/Sized/Vect.hs b/bundled/Basement/Sized/Vect.hs new file mode 100644 index 0000000..be98afa --- /dev/null +++ b/bundled/Basement/Sized/Vect.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +module Basement.Sized.Vect + ( Vect + , MVect + , unVect + , toVect + , empty + , singleton + , replicate + , thaw + , freeze + , index + , map + , foldl' + , foldr + , cons + , snoc + , elem + , sub + , uncons + , unsnoc + , splitAt + , all + , any + , find + , reverse + , sortBy + , intersperse + ) where + +import Basement.Compat.Base +import Basement.Nat +import Basement.NormalForm +import Basement.Types.OffsetSize +import Basement.Monad +import Basement.PrimType (PrimType) +import qualified Basement.BoxedArray as A +--import qualified Basement.BoxedArray.Mutable as A hiding (sub) +import Data.Proxy + +newtype Vect (n :: Nat) a = Vect { unVect :: A.Array a } deriving (NormalForm, Eq, Show) +newtype MVect (n :: Nat) ty st = MVect { unMVect :: A.MArray ty st } + +instance Functor (Vect n) where + fmap = map + +toVect :: forall n ty . (KnownNat n, Countable ty n) => A.Array ty -> Maybe (Vect n ty) +toVect b + | expected == A.length b = Just (Vect b) + | otherwise = Nothing + where + expected = toCount @n + +empty :: Vect 0 ty +empty = Vect A.empty + +singleton :: ty -> Vect 1 ty +singleton a = Vect (A.singleton a) + +create :: forall a (n :: Nat) . (Countable a n, KnownNat n) => (Offset a -> a) -> Vect n a +create f = Vect $ A.create sz f + where + sz = natValCountOf (Proxy :: Proxy n) + +replicate :: forall n ty . (KnownNat n, Countable ty n) => ty -> Vect n ty +replicate a = Vect (A.replicate (toCount @n) a) + +thaw :: (KnownNat n, PrimMonad prim) => Vect n ty -> prim (MVect n ty (PrimState prim)) +thaw b = MVect <$> A.thaw (unVect b) + +freeze :: (PrimMonad prim, Countable ty n) => MVect n ty (PrimState prim) -> prim (Vect n ty) +freeze b = Vect <$> A.freeze (unMVect b) + +write :: PrimMonad prim => MVect n ty (PrimState prim) -> Offset ty -> ty -> prim () +write (MVect ma) ofs v = A.write ma ofs v + +read :: PrimMonad prim => MVect n ty (PrimState prim) -> Offset ty -> prim ty +read (MVect ma) ofs = A.read ma ofs + +indexStatic :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, Offsetable ty i) => Vect n ty -> ty +indexStatic b = A.unsafeIndex (unVect b) (toOffset @i) + +index :: Vect n ty -> Offset ty -> ty +index b ofs = A.index (unVect b) ofs + +map :: (a -> b) -> Vect n a -> Vect n b +map f b = Vect (fmap f (unVect b)) + +foldl' :: (a -> ty -> a) -> a -> Vect n ty -> a +foldl' f acc b = A.foldl' f acc (unVect b) + +foldr :: (ty -> a -> a) -> a -> Vect n ty -> a +foldr f acc b = A.foldr f acc (unVect b) + +cons :: ty -> Vect n ty -> Vect (n+1) ty +cons e = Vect . A.cons e . unVect + +snoc :: Vect n ty -> ty -> Vect (n+1) ty +snoc b = Vect . A.snoc (unVect b) + +sub :: forall i j n ty + . ( (i <=? n) ~ 'True + , (j <=? n) ~ 'True + , (i <=? j) ~ 'True + , KnownNat i + , KnownNat j + , Offsetable ty i + , Offsetable ty j ) + => Vect n ty + -> Vect (j-i) ty +sub block = Vect (A.sub (unVect block) (toOffset @i) (toOffset @j)) + +uncons :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, Offsetable ty n) + => Vect n ty + -> (ty, Vect (n-1) ty) +uncons b = (indexStatic @0 b, Vect (A.sub (unVect b) 1 (toOffset @n))) + +unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, Offsetable ty n) + => Vect n ty + -> (Vect (n-1) ty, ty) +unsnoc b = + ( Vect (A.sub (unVect b) 0 (toOffset @n `offsetSub` 1)) + , A.unsafeIndex (unVect b) (toOffset @n `offsetSub` 1)) + +splitAt :: forall i n ty . (CmpNat i n ~ 'LT, KnownNat i, Countable ty i) => Vect n ty -> (Vect i ty, Vect (n-i) ty) +splitAt b = + let (left, right) = A.splitAt (toCount @i) (unVect b) + in (Vect left, Vect right) + +elem :: Eq ty => ty -> Vect n ty -> Bool +elem e b = A.elem e (unVect b) + +all :: (ty -> Bool) -> Vect n ty -> Bool +all p b = A.all p (unVect b) + +any :: (ty -> Bool) -> Vect n ty -> Bool +any p b = A.any p (unVect b) + +find :: (ty -> Bool) -> Vect n ty -> Maybe ty +find p b = A.find p (unVect b) + +reverse :: Vect n ty -> Vect n ty +reverse = Vect . A.reverse . unVect + +sortBy :: (ty -> ty -> Ordering) -> Vect n ty -> Vect n ty +sortBy f b = Vect (A.sortBy f (unVect b)) + +intersperse :: (CmpNat n 1 ~ 'GT) => ty -> Vect n ty -> Vect (n+n-1) ty +intersperse sep b = Vect (A.intersperse sep (unVect b)) + +toCount :: forall n ty . (KnownNat n, Countable ty n) => CountOf ty +toCount = natValCountOf (Proxy @n) + +toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty +toOffset = natValOffset (Proxy @n) diff --git a/bundled/Basement/String.hs b/bundled/Basement/String.hs new file mode 100644 index 0000000..6f89fc2 --- /dev/null +++ b/bundled/Basement/String.hs @@ -0,0 +1,1479 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.String +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- A String type backed by a UTF8 encoded byte array and all the necessary +-- functions to manipulate the string. +-- +-- You can think of String as a specialization of a byte array that +-- have element of type Char. +-- +-- The String data must contain UTF8 valid data. +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +module Basement.String + ( String(..) + , MutableString(..) + , create + , replicate + , length + -- * Binary conversion + , Encoding(..) + , fromBytes + , fromChunkBytes + , fromBytesUnsafe + , fromBytesLenient + , toBytes + , mutableValidate + , copy + , ValidationFailure(..) + , index + , null + , drop + , take + , splitAt + , revDrop + , revTake + , revSplitAt + , splitOn + , sub + , elem + , indices + , intersperse + , span + , spanEnd + , break + , breakEnd + , breakElem + , breakLine + , dropWhile + , singleton + , charMap + , snoc + , cons + , unsnoc + , uncons + , find + , findIndex + , sortBy + , filter + , reverse + , replace + , builderAppend + , builderBuild + , builderBuild_ + , readInteger + , readIntegral + , readNatural + , readDouble + , readRational + , readFloatingExact + , upper + , lower + , caseFold + , isPrefixOf + , isSuffixOf + , isInfixOf + , stripPrefix + , stripSuffix + , all + , any + -- * Legacy utility + , lines + , words + , toBase64 + , toBase64URL + , toBase64OpenBSD + ) where + +import Basement.UArray (UArray) +import qualified Basement.UArray as Vec +import qualified Basement.UArray as C +import qualified Basement.UArray.Mutable as MVec +import Basement.Block.Mutable (Block(..), MutableBlock(..)) +import qualified Basement.Block.Mutable as MBLK +import Basement.Compat.Bifunctor +import Basement.Compat.Base +import Basement.Compat.Natural +import Basement.Compat.MonadTrans +import Basement.Compat.Primitive +import Basement.Types.OffsetSize +import Basement.Numerical.Additive +import Basement.Numerical.Subtractive +import Basement.Numerical.Multiplicative +import Basement.Numerical.Number +import Basement.Cast +import Basement.Monad +import Basement.PrimType +import Basement.FinalPtr +import Basement.IntegralConv +import Basement.Floating +import Basement.MutableBuilder +import Basement.String.CaseMapping (upperMapping, lowerMapping, foldMapping) +import Basement.UTF8.Table +import Basement.UTF8.Helper +import Basement.UTF8.Base +import Basement.UTF8.Types +import Basement.UArray.Base as C (onBackendPrim, onBackend, onBackendPure, offset, ValidRange(..), offsetsValidRange, MUArray(..), MUArrayBackend(..)) +import Basement.Alg.Class (Indexable) +import qualified Basement.Alg.UTF8 as UTF8 +import qualified Basement.Alg.String as Alg +import Basement.Types.Char7 (Char7(..), c7Upper, c7Lower) +import qualified Basement.Types.Char7 as Char7 +import GHC.Prim +import GHC.ST +import GHC.Types +import GHC.Word +#if MIN_VERSION_base(4,9,0) +import GHC.Char +#endif + + -- temporary +import qualified Data.List +import Data.Ratio +import Data.Char (toUpper, toLower) +import qualified Prelude + +import qualified Basement.String.Encoding.Encoding as Encoder +import qualified Basement.String.Encoding.ASCII7 as Encoder +import qualified Basement.String.Encoding.UTF16 as Encoder +import qualified Basement.String.Encoding.UTF32 as Encoder +import qualified Basement.String.Encoding.ISO_8859_1 as Encoder + +-- | UTF8 Encoder +data EncoderUTF8 = EncoderUTF8 + +instance Encoder.Encoding EncoderUTF8 where + type Unit EncoderUTF8 = Word8 + type Error EncoderUTF8 = ValidationFailure + encodingNext _ = \ofs -> Right . nextWithIndexer ofs + encodingWrite _ = writeWithBuilder + +-- | Validate a bytearray for UTF8'ness +-- +-- On success Nothing is returned +-- On Failure the position along with the failure reason +validate :: UArray Word8 + -> Offset8 + -> CountOf Word8 + -> (Offset8, Maybe ValidationFailure) +validate array ofsStart sz = C.unsafeDewrap goBa goAddr array + where + unTranslateOffset start = first (\e -> e `offsetSub` start) + goBa ba start = + unTranslateOffset start $ Alg.validate (start+end) ba (start + ofsStart) + goAddr ptr@(Ptr !_) start = + pure $ unTranslateOffset start $ Alg.validate (start+end) ptr (ofsStart + start) + end = ofsStart `offsetPlusE` sz + +-- | Similar to 'validate' but works on a 'MutableByteArray' +mutableValidate :: PrimMonad prim + => MVec.MUArray Word8 (PrimState prim) + -> Offset Word8 + -> CountOf Word8 + -> prim (Offset Word8, Maybe ValidationFailure) +mutableValidate mba ofsStart sz = do + loop ofsStart + where + end = ofsStart `offsetPlusE` sz + + loop ofs + | ofs > end = error "mutableValidate: internal error: went pass offset" + | ofs == end = return (end, Nothing) + | otherwise = do + r <- one ofs + case r of + (nextOfs, Nothing) -> loop nextOfs + (pos, Just failure) -> return (pos, Just failure) + + one pos = do + h <- StepASCII <$> Vec.unsafeRead mba pos + let nbConts = getNbBytes h + if nbConts == 0xff + then return (pos, Just InvalidHeader) + else if pos + 1 + Offset nbConts > end + then return (pos, Just MissingByte) + else do + case nbConts of + 0 -> return (pos + 1, Nothing) + 1 -> do + c1 <- Vec.unsafeRead mba (pos + 1) + if isContinuation c1 + then return (pos + 2, Nothing) + else return (pos, Just InvalidContinuation) + 2 -> do + c1 <- Vec.unsafeRead mba (pos + 1) + c2 <- Vec.unsafeRead mba (pos + 2) + if isContinuation c1 && isContinuation c2 + then return (pos + 3, Nothing) + else return (pos, Just InvalidContinuation) + 3 -> do + c1 <- Vec.unsafeRead mba (pos + 1) + c2 <- Vec.unsafeRead mba (pos + 2) + c3 <- Vec.unsafeRead mba (pos + 3) + if isContinuation c1 && isContinuation c2 && isContinuation c3 + then return (pos + 4, Nothing) + else return (pos, Just InvalidContinuation) + _ -> error "internal error" + +nextWithIndexer :: (Offset Word8 -> Word8) + -> Offset Word8 + -> (Char, Offset Word8) +nextWithIndexer getter off = + case getNbBytes# b# of + 0# -> (toChar h, off + 1) + 1# -> (toChar (decode2 (getter $ off + 1)), off + 2) + 2# -> (toChar (decode3 (getter $ off + 1) (getter $ off + 2)), off + 3) + 3# -> (toChar (decode4 (getter $ off + 1) (getter $ off + 2) (getter $ off + 3)) + , off + 4) + r -> error ("next: internal error: invalid input: " <> show (I# r) <> " " <> show (W# h)) + where + b@(W8# b#) = getter off + !(W# h) = integralUpsize b + + toChar :: Word# -> Char + toChar w = C# (chr# (word2Int# w)) + + decode2 :: Word8 -> Word# + decode2 (W8# b1) = + or# (uncheckedShiftL# (and# h 0x1f##) 6#) + (and# c1 0x3f##) + where + c1 = word8ToWord# b1 + + decode3 :: Word8 -> Word8 -> Word# + decode3 (W8# b1) (W8# b2) = + or# (uncheckedShiftL# (and# h 0xf##) 12#) + (or# (uncheckedShiftL# (and# c1 0x3f##) 6#) + (and# c2 0x3f##)) + where + c1 = word8ToWord# b1 + c2 = word8ToWord# b2 + + decode4 :: Word8 -> Word8 -> Word8 -> Word# + decode4 (W8# b1) (W8# b2) (W8# b3) = + or# (uncheckedShiftL# (and# h 0x7##) 18#) + (or# (uncheckedShiftL# (and# c1 0x3f##) 12#) + (or# (uncheckedShiftL# (and# c2 0x3f##) 6#) + (and# c3 0x3f##)) + ) + where + c1 = word8ToWord# b1 + c2 = word8ToWord# b2 + c3 = word8ToWord# b3 + +writeWithBuilder :: (PrimMonad st, Monad st) + => Char + -> Builder (UArray Word8) (MVec.MUArray Word8) Word8 st err () +writeWithBuilder c + | bool# (ltWord# x 0x80## ) = encode1 + | bool# (ltWord# x 0x800## ) = encode2 + | bool# (ltWord# x 0x10000##) = encode3 + | otherwise = encode4 + where + !(I# xi) = fromEnum c + !x = int2Word# xi + + encode1 = Vec.builderAppend (W8# (wordToWord8# x)) + + encode2 = do + let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## + x2 = toContinuation x + Vec.builderAppend (W8# (wordToWord8# x1)) >> Vec.builderAppend (W8# (wordToWord8# x2)) + + encode3 = do + let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## + x2 = toContinuation (uncheckedShiftRL# x 6#) + x3 = toContinuation x + Vec.builderAppend (W8# (wordToWord8# x1)) >> Vec.builderAppend (W8# (wordToWord8# x2)) >> Vec.builderAppend (W8# (wordToWord8# x3)) + + encode4 = do + let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## + x2 = toContinuation (uncheckedShiftRL# x 12#) + x3 = toContinuation (uncheckedShiftRL# x 6#) + x4 = toContinuation x + Vec.builderAppend (W8# (wordToWord8# x1)) >> Vec.builderAppend (W8# (wordToWord8# x2)) >> Vec.builderAppend (W8# (wordToWord8# x3)) >> Vec.builderAppend (W8# (wordToWord8# x4)) + + toContinuation :: Word# -> Word# + toContinuation w = or# (and# w 0x3f##) 0x80## + +writeUTF8Char :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> UTF8Char -> prim () +writeUTF8Char (MutableString mba) i (UTF8_1 x1) = + Vec.unsafeWrite mba i x1 +writeUTF8Char (MutableString mba) i (UTF8_2 x1 x2) = do + Vec.unsafeWrite mba i x1 + Vec.unsafeWrite mba (i+1) x2 +writeUTF8Char (MutableString mba) i (UTF8_3 x1 x2 x3) = do + Vec.unsafeWrite mba i x1 + Vec.unsafeWrite mba (i+1) x2 + Vec.unsafeWrite mba (i+2) x3 +writeUTF8Char (MutableString mba) i (UTF8_4 x1 x2 x3 x4) = do + Vec.unsafeWrite mba i x1 + Vec.unsafeWrite mba (i+1) x2 + Vec.unsafeWrite mba (i+2) x3 + Vec.unsafeWrite mba (i+3) x4 +{-# INLINE writeUTF8Char #-} + +unsafeFreezeShrink :: PrimMonad prim => MutableString (PrimState prim) -> CountOf Word8 -> prim String +unsafeFreezeShrink (MutableString mba) s = String <$> Vec.unsafeFreezeShrink mba s +{-# INLINE unsafeFreezeShrink #-} + +------------------------------------------------------------------------ +-- real functions + +-- | Check if a String is null +null :: String -> Bool +null (String ba) = C.length ba == 0 + +-- we don't know in constant time the count of character in string, +-- however if we estimate bounds of what N characters would +-- take in space (between N and N*4). If the count is thus bigger than +-- the number of bytes, then we know for sure that it's going to +-- be out of bounds +countCharMoreThanBytes :: CountOf Char -> UArray Word8 -> Bool +countCharMoreThanBytes (CountOf chars) ba = chars >= bytes + where (CountOf bytes) = C.length ba + +-- | Create a string composed of a number @n of Chars (Unicode code points). +-- +-- if the input @s contains less characters than required, then the input string is returned. +take :: CountOf Char -> String -> String +take n s@(String ba) + | n <= 0 = mempty + | countCharMoreThanBytes n ba = s + | otherwise = String $ Vec.unsafeTake (offsetAsSize $ indexN n s) ba + +-- | Create a string with the remaining Chars after dropping @n Chars from the beginning +drop :: CountOf Char -> String -> String +drop n s@(String ba) + | n <= 0 = s + | countCharMoreThanBytes n ba = mempty + | otherwise = String $ Vec.drop (offsetAsSize $ indexN n s) ba + +-- | Split a string at the Offset specified (in Char) returning both +-- the leading part and the remaining part. +splitAt :: CountOf Char -> String -> (String, String) +splitAt n s@(String ba) + | n <= 0 = (mempty, s) + | countCharMoreThanBytes n ba = (s, mempty) + | otherwise = + let (v1,v2) = C.splitAt (offsetAsSize $ indexN n s) ba + in (String v1, String v2) + +-- | Return the offset (in bytes) of the N'th sequence in an UTF8 String +indexN :: CountOf Char -> String -> Offset Word8 +indexN !n (String ba) = Vec.unsafeDewrap goVec goAddr ba + where + goVec :: Block Word8 -> Offset Word8 -> Offset Word8 + goVec (Block !ma) !start = loop start 0 + where + !len = start `offsetPlusE` Vec.length ba + loop :: Offset Word8 -> Offset Char -> Offset Word8 + loop !idx !i + | idx >= len || i .==# n = sizeAsOffset (idx - start) + | otherwise = loop (idx `offsetPlusE` d) (i + Offset 1) + where d = skipNextHeaderValue (primBaIndex ma idx) + {-# INLINE goVec #-} + + goAddr :: Ptr Word8 -> Offset Word8 -> ST s (Offset Word8) + goAddr (Ptr ptr) !start = return $ loop start (Offset 0) + where + !len = start `offsetPlusE` Vec.length ba + loop :: Offset Word8 -> Offset Char -> Offset Word8 + loop !idx !i + | idx >= len || i .==# n = sizeAsOffset (idx - start) + | otherwise = loop (idx `offsetPlusE` d) (i + Offset 1) + where d = skipNextHeaderValue (primAddrIndex ptr idx) + {-# INLINE goAddr #-} +{-# INLINE indexN #-} + +-- inverse a CountOf that is specified from the end (e.g. take n Chars from the end) +-- +-- rev{Take,Drop,SplitAt} TODO optimise: +-- we can process the string from the end using a skipPrev instead of getting the length +countFromStart :: String -> CountOf Char -> CountOf Char +countFromStart s sz@(CountOf sz') + | sz >= len = CountOf 0 + | otherwise = CountOf (len' - sz') + where len@(CountOf len') = length s + +-- | Similar to 'take' but from the end +revTake :: CountOf Char -> String -> String +revTake n v = drop (countFromStart v n) v + +-- | Similar to 'drop' but from the end +revDrop :: CountOf Char -> String -> String +revDrop n v = take (countFromStart v n) v + +-- | Similar to 'splitAt' but from the end +revSplitAt :: CountOf Char -> String -> (String, String) +revSplitAt n v = (drop idx v, take idx v) where idx = countFromStart v n + +-- | Split on the input string using the predicate as separator +-- +-- e.g. +-- +-- > splitOn (== ',') "," == ["",""] +-- > splitOn (== ',') ",abc," == ["","abc",""] +-- > splitOn (== ':') "abc" == ["abc"] +-- > splitOn (== ':') "abc::def" == ["abc","","def"] +-- > splitOn (== ':') "::abc::def" == ["","","abc","","def"] +-- +splitOn :: (Char -> Bool) -> String -> [String] +splitOn predicate s + | sz == CountOf 0 = [mempty] + | otherwise = loop azero azero + where + !sz = size s + end = azero `offsetPlusE` sz + loop prevIdx idx + | idx == end = [sub s prevIdx idx] + | otherwise = + let !(Step c idx') = next s idx + in if predicate c + then sub s prevIdx idx : loop idx' idx' + else loop prevIdx idx' + +-- | Internal call to make a substring given offset in bytes. +-- +-- This is unsafe considering that one can create a substring +-- starting and/or ending on the middle of a UTF8 sequence. +sub :: String -> Offset8 -> Offset8 -> String +sub (String ba) start end = String $ Vec.sub ba start end + +-- | Internal call to split at a given index in offset of bytes. +-- +-- This is unsafe considering that one can split in the middle of a +-- UTF8 sequence, so use with care. +splitIndex :: Offset8 -> String -> (String, String) +splitIndex idx (String ba) = (String v1, String v2) + where (v1,v2) = C.splitAt (offsetAsSize idx) ba + +-- | Break a string into 2 strings at the location where the predicate return True +break :: (Char -> Bool) -> String -> (String, String) +break predicate s@(String ba) = runST $ Vec.unsafeIndexer ba go + where + !sz = size s + end = azero `offsetPlusE` sz + + go :: (Offset Word8 -> Word8) -> ST st (String, String) + go getIdx = loop (Offset 0) + where + !nextI = nextWithIndexer getIdx + loop idx + | idx == end = return (s, mempty) + | otherwise = do + let (c, idx') = nextI idx + case predicate c of + True -> return $ splitIndex idx s + False -> loop idx' + {-# INLINE loop #-} +{-# INLINE [2] break #-} + +breakEnd :: (Char -> Bool) -> String -> (String, String) +breakEnd predicate s@(String arr) + | k == end = (s, mempty) + | otherwise = splitIndex (k `offsetSub` start) s + where + k = C.onBackend goVec (\_ -> pure . goAddr) arr + (C.ValidRange !start !end) = offsetsValidRange arr + goVec ba@(Block !_) = let k = Alg.revFindIndexPredicate predicate ba start end + in if k == end then end else UTF8.nextSkip ba k + goAddr ptr@(Ptr !_) = + let k = Alg.revFindIndexPredicate predicate ptr start end + in if k == end then end else UTF8.nextSkip ptr k +{-# INLINE [2] breakEnd #-} + +#if MIN_VERSION_base(4,9,0) +{-# RULES "break (== 'c')" [3] forall c . break (eqChar c) = breakElem c #-} +#else +{-# RULES "break (== 'c')" [3] forall c . break (== c) = breakElem c #-} +#endif + +-- | Break a string into 2 strings at the first occurence of the character +breakElem :: Char -> String -> (String, String) +breakElem !el s@(String ba) + | sz == 0 = (mempty, mempty) + | otherwise = + case asUTF8Char el of + UTF8_1 w -> let !(v1,v2) = Vec.breakElem w ba in (String v1, String v2) + _ -> runST $ Vec.unsafeIndexer ba go + where + sz = size s + end = azero `offsetPlusE` sz + + go :: (Offset Word8 -> Word8) -> ST st (String, String) + go getIdx = loop (Offset 0) + where + !nextI = nextWithIndexer getIdx + loop idx + | idx == end = return (s, mempty) + | otherwise = do + let (c, idx') = nextI idx + case el == c of + True -> return $ splitIndex idx s + False -> loop idx' + +-- | Same as break but cut on a line feed with an optional carriage return. +-- +-- This is the same operation as 'breakElem LF' dropping the last character of the +-- string if it's a CR. +-- +-- Also for efficiency reason (streaming), it returns if the last character was a CR character. +breakLine :: String -> Either Bool (String, String) +breakLine (String arr) = bimap String String <$> Vec.breakLine arr + +-- | Apply a @predicate@ to the string to return the longest prefix that satisfy the predicate and +-- the remaining +span :: (Char -> Bool) -> String -> (String, String) +span predicate s = break (not . predicate) s + +-- | Apply a @predicate@ to the string to return the longest suffix that satisfy the predicate and +-- the remaining +spanEnd :: (Char -> Bool) -> String -> (String, String) +spanEnd predicate s = breakEnd (not . predicate) s + +-- | Drop character from the beginning while the predicate is true +dropWhile :: (Char -> Bool) -> String -> String +dropWhile predicate = snd . break (not . predicate) + +-- | Return whereas the string contains a specific character or not +elem :: Char -> String -> Bool +elem !el s@(String ba) = + case asUTF8Char el of + UTF8_1 w -> Vec.elem w ba + _ -> runST $ Vec.unsafeIndexer ba go + where + sz = size s + end = azero `offsetPlusE` sz + + go :: (Offset Word8 -> Word8) -> ST st Bool + go getIdx = loop (Offset 0) + where + !nextI = nextWithIndexer getIdx + loop !idx + | idx == end = return False + | otherwise = do + let (c, idx') = nextI idx + case el == c of + True -> return True + False -> loop idx' + +-- | Intersperse the character @sep@ between each character in the string +-- +-- > intersperse ' ' "Hello Foundation" +-- "H e l l o F o u n d a t i o n" +intersperse :: Char -> String -> String +intersperse sep src = case length src - 1 of + Nothing -> src + Just 0 -> src + Just gaps -> runST $ unsafeCopyFrom src dstBytes go + where + lastSrcI :: Offset Char + lastSrcI = 0 `offsetPlusE` gaps + dstBytes = (size src :: CountOf Word8) + (gaps `scale` charToBytes (fromEnum sep)) + + go :: String -> Offset Char -> Offset8 -> MutableString s -> Offset8 -> ST s (Offset8, Offset8) + go src' srcI srcIdx dst dstIdx + | srcI == lastSrcI = do + nextDstIdx <- write dst dstIdx c + return (nextSrcIdx, nextDstIdx) + | otherwise = do + nextDstIdx <- write dst dstIdx c + nextDstIdx' <- write dst nextDstIdx sep + return (nextSrcIdx, nextDstIdx') + where + !(Step c nextSrcIdx) = next src' srcIdx + +-- | Allocate a new @String@ with a fill function that has access to the characters of +-- the source @String@. +unsafeCopyFrom :: String -- ^ Source string + -> CountOf Word8 -- ^ Length of the destination string in bytes + -> (String -> Offset Char -> Offset8 -> MutableString s -> Offset8 -> ST s (Offset8, Offset8)) + -- ^ Function called for each character in the source String + -> ST s String -- ^ Returns the filled new string +unsafeCopyFrom src dstBytes f = new dstBytes >>= fill (Offset 0) (Offset 0) (Offset 0) f >>= freeze + where + srcLen = length src + end = Offset 0 `offsetPlusE` srcLen + fill srcI srcIdx dstIdx f' dst' + | srcI == end = return dst' + | otherwise = do (nextSrcIdx, nextDstIdx) <- f' src srcI srcIdx dst' dstIdx + fill (srcI + Offset 1) nextSrcIdx nextDstIdx f' dst' + +-- | Length of a String using CountOf +-- +-- this size is available in o(n) +length :: String -> CountOf Char +length (String arr) + | start == end = 0 + | otherwise = C.onBackend goVec (\_ -> pure . goAddr) arr + where + (C.ValidRange !start !end) = offsetsValidRange arr + goVec ma = UTF8.length ma start end + goAddr ptr = UTF8.length ptr start end + +-- | Replicate a character @c@ @n@ times to create a string of length @n@ +replicate :: CountOf Char -> Char -> String +replicate (CountOf n) c = runST (new nbBytes >>= fill) + where + nbBytes = scale (cast n :: Word) sz + sz = charToBytes (fromEnum c) + fill :: PrimMonad prim => MutableString (PrimState prim) -> prim String + fill ms = loop (Offset 0) + where + loop idx + | idx .==# nbBytes = freeze ms + | otherwise = write ms idx c >>= loop + +-- | Copy the String +-- +-- The slice of memory is copied to a new slice, making the new string +-- independent from the original string.. +copy :: String -> String +copy (String s) = String (Vec.copy s) + +-- | Create a single element String +singleton :: Char -> String +singleton c = runST $ do + ms <- new nbBytes + _ <- write ms (Offset 0) c + freeze ms + where + !nbBytes = charToBytes (fromEnum c) + +-- | Unsafely create a string of up to @sz@ bytes. +-- +-- The callback @f@ needs to return the number of bytes filled in the underlaying +-- bytes buffer. No check is made on the callback return values, and if it's not +-- contained without the bounds, bad things will happen. +create :: PrimMonad prim => CountOf Word8 -> (MutableString (PrimState prim) -> prim (Offset Word8)) -> prim String +create sz f = do + ms <- new sz + filled <- f ms + if filled .==# sz + then freeze ms + else do + s <- freeze ms + let (String ba) = s + pure $ String $ C.take (offsetAsSize filled) ba + +-- | Monomorphically map the character in a string and return the transformed one +charMap :: (Char -> Char) -> String -> String +charMap f src + | srcSz == 0 = mempty + | otherwise = + let !(elems, nbBytes) = allocateAndFill [] (Offset 0) (CountOf 0) + in runST $ do + dest <- new nbBytes + copyLoop dest elems (Offset 0 `offsetPlusE` nbBytes) + freeze dest + where + !srcSz = size src + srcEnd = azero `offsetPlusE` srcSz + + allocateAndFill :: [(String, CountOf Word8)] + -> Offset8 + -> CountOf Word8 + -> ([(String,CountOf Word8)], CountOf Word8) + allocateAndFill acc idx bytesWritten + | idx == srcEnd = (acc, bytesWritten) + | otherwise = + let (el@(_,addBytes), idx') = runST $ do + -- make sure we allocate at least 4 bytes for the destination for the last few bytes + -- otherwise allocating less would bring the danger of spinning endlessly + -- and never succeeding. + let !diffBytes = srcEnd - idx + !allocatedBytes = if diffBytes <= CountOf 4 then CountOf 4 else diffBytes + ms <- new allocatedBytes + (dstIdx, srcIdx) <- fill ms allocatedBytes idx + s <- freeze ms + return ((s, dstIdx), srcIdx) + in allocateAndFill (el : acc) idx' (bytesWritten + addBytes) + + fill :: PrimMonad prim + => MutableString (PrimState prim) + -> CountOf Word8 + -> Offset8 + -> prim (CountOf Word8, Offset8) + fill mba dsz srcIdxOrig = + loop (Offset 0) srcIdxOrig + where + endDst = (Offset 0) `offsetPlusE` dsz + loop dstIdx srcIdx + | srcIdx == srcEnd = return (offsetAsSize dstIdx, srcIdx) + | dstIdx == endDst = return (offsetAsSize dstIdx, srcIdx) + | otherwise = + let !(Step c srcIdx') = next src srcIdx + c' = f c -- the mapped char + !nbBytes = charToBytes (fromEnum c') + in -- check if we have room in the destination buffer + if dstIdx `offsetPlusE` nbBytes <= sizeAsOffset dsz + then do dstIdx' <- write mba dstIdx c' + loop dstIdx' srcIdx' + else return (offsetAsSize dstIdx, srcIdx) + + copyLoop _ [] (Offset 0) = return () + copyLoop _ [] n = error ("charMap invalid: " <> show n) + copyLoop ms@(MutableString mba) ((String ba, sz):xs) end = do + let start = end `offsetMinusE` sz + Vec.unsafeCopyAtRO mba start ba (Offset 0) sz + copyLoop ms xs start + +-- | Append a Char to the end of the String and return this new String +snoc :: String -> Char -> String +snoc s@(String ba) c + | len == CountOf 0 = singleton c + | otherwise = runST $ do + ms <- new (len + nbBytes) + let (MutableString mba) = ms + Vec.unsafeCopyAtRO mba (Offset 0) ba (Offset 0) len + _ <- write ms (azero `offsetPlusE` len) c + freeze ms + where + !len = size s + !nbBytes = charToBytes (fromEnum c) + +-- | Prepend a Char to the beginning of the String and return this new String +cons :: Char -> String -> String +cons c s@(String ba) + | len == CountOf 0 = singleton c + | otherwise = runST $ do + ms <- new (len + nbBytes) + let (MutableString mba) = ms + idx <- write ms (Offset 0) c + Vec.unsafeCopyAtRO mba idx ba (Offset 0) len + freeze ms + where + !len = size s + !nbBytes = charToBytes (fromEnum c) + +-- | Extract the String stripped of the last character and the last character if not empty +-- +-- If empty, Nothing is returned +unsnoc :: String -> Maybe (String, Char) +unsnoc s@(String arr) + | sz == 0 = Nothing + | otherwise = + let !(StepBack c idx) = prev s (sizeAsOffset sz) + in Just (String $ Vec.take (offsetAsSize idx) arr, c) + where + sz = size s + +-- | Extract the First character of a string, and the String stripped of the first character. +-- +-- If empty, Nothing is returned +uncons :: String -> Maybe (Char, String) +uncons s@(String ba) + | null s = Nothing + | otherwise = + let !(Step c idx) = next s azero + in Just (c, String $ Vec.drop (offsetAsSize idx) ba) + +-- | Look for a predicate in the String and return the matched character, if any. +find :: (Char -> Bool) -> String -> Maybe Char +find predicate s = loop (Offset 0) + where + !sz = size s + end = Offset 0 `offsetPlusE` sz + loop idx + | idx == end = Nothing + | otherwise = + let !(Step c idx') = next s idx + in case predicate c of + True -> Just c + False -> loop idx' + +-- | Sort the character in a String using a specific sort function +-- +-- TODO: optimise not going through a list +sortBy :: (Char -> Char -> Ordering) -> String -> String +sortBy sortF s = fromList $ Data.List.sortBy sortF $ toList s -- FIXME for tests + +-- | Filter characters of a string using the predicate +filter :: (Char -> Bool) -> String -> String +filter predicate (String arr) = runST $ do + (finalSize, dst) <- newNative sz $ \(MutableBlock mba) -> + C.onBackendPrim (\ba@(Block !_) -> Alg.copyFilter predicate sz mba ba start) + (\fptr -> withFinalPtr fptr $ \ptr@(Ptr !_) -> Alg.copyFilter predicate sz mba ptr start) + arr + freezeShrink finalSize dst + where + !sz = C.length arr + !start = C.offset arr + +-- | Reverse a string +reverse :: String -> String +reverse (String arr) = runST $ do + s <- newNative_ (C.length arr) $ \(MutableBlock mba) -> + C.onBackendPrim + (\ba@(Block !_) -> UTF8.reverse mba 0 ba start end) + (\fptr -> withFinalPtr fptr $ \ptr@(Ptr !_) -> UTF8.reverse mba 0 ptr start end) + arr + freeze s + where + !(C.ValidRange start end) = C.offsetsValidRange arr + +-- | Finds where are the insertion points when we search for a `needle` +-- within an `haystack`. +indices :: String -> String -> [Offset8] +indices (String ned) (String hy) = Vec.indices ned hy + +-- | Replace all the occurrencies of `needle` with `replacement` in +-- the `haystack` string. +replace :: String -> String -> String -> String +replace (String needle) (String replacement) (String haystack) = + String $ Vec.replace needle replacement haystack + +-- | Return the nth character in a String +-- +-- Compared to an array, the string need to be scanned from the beginning +-- since the UTF8 encoding is variable. +index :: String -> Offset Char -> Maybe Char +index s n + | ofs >= end = Nothing + | otherwise = + let (Step !c _) = next s ofs + in Just c + where + !nbBytes = size s + end = 0 `offsetPlusE` nbBytes + ofs = indexN (offsetAsSize n) s + +-- | Return the index in unit of Char of the first occurence of the predicate returning True +-- +-- If not found, Nothing is returned +findIndex :: (Char -> Bool) -> String -> Maybe (Offset Char) +findIndex predicate s = loop 0 0 + where + !sz = size s + loop ofs idx + | idx .==# sz = Nothing + | otherwise = + let !(Step c idx') = next s idx + in case predicate c of + True -> Just ofs + False -> loop (ofs+1) idx' + +-- | Various String Encoding that can be use to convert to and from bytes +data Encoding + = ASCII7 + | UTF8 + | UTF16 + | UTF32 + | ISO_8859_1 + deriving (Typeable, Data, Eq, Ord, Show, Enum, Bounded) + +fromEncoderBytes :: ( Encoder.Encoding encoding + , PrimType (Encoder.Unit encoding) + ) + => encoding + -> UArray Word8 + -> (String, Maybe ValidationFailure, UArray Word8) +fromEncoderBytes enc bytes = + case runST $ Encoder.convertFromTo enc EncoderUTF8 (Vec.recast bytes) of + -- TODO: Don't swallow up specific error (second element of pair) + -- TODO: Confused why all this recasting is necessary. I "typed hole"-ed my way to get this function to compile. Feels like there should be a cleaner method. + Left (off, _) -> + let (b1, b2) = Vec.splitAt (offsetAsSize off) (Vec.recast bytes) + in (String $ Vec.recast b1, Just BuildingFailure, Vec.recast b2) + Right converted -> (String converted, Nothing, mempty) + +-- | Convert a ByteArray to a string assuming a specific encoding. +-- +-- It returns a 3-tuple of: +-- +-- * The string that has been succesfully converted without any error +-- * An optional validation error +-- * The remaining buffer that hasn't been processed (either as a result of an error, or because the encoded sequence is not fully available) +-- +-- Considering a stream of data that is fetched chunk by chunk, it's valid to assume +-- that some sequence might fall in a chunk boundary. When converting chunks, +-- if the error is Nothing and the remaining buffer is not empty, then this buffer +-- need to be prepended to the next chunk +fromBytes :: Encoding -> UArray Word8 -> (String, Maybe ValidationFailure, UArray Word8) +fromBytes ASCII7 bytes = fromEncoderBytes Encoder.ASCII7 bytes +fromBytes ISO_8859_1 bytes = fromEncoderBytes Encoder.ISO_8859_1 bytes +fromBytes UTF16 bytes = fromEncoderBytes Encoder.UTF16 bytes +fromBytes UTF32 bytes = fromEncoderBytes Encoder.UTF32 bytes +fromBytes UTF8 bytes + | C.null bytes = (mempty, Nothing, mempty) + | otherwise = + case validate bytes (Offset 0) (C.length bytes) of + (_, Nothing) -> (fromBytesUnsafe bytes, Nothing, mempty) + (pos, Just vf) -> + let (b1, b2) = C.splitAt (offsetAsSize pos) bytes + in (fromBytesUnsafe b1, toErr vf, b2) + where + toErr MissingByte = Nothing + toErr InvalidHeader = Just InvalidHeader + toErr InvalidContinuation = Just InvalidContinuation + toErr BuildingFailure = Just BuildingFailure + +-- | Convert a UTF8 array of bytes to a String. +-- +-- If there's any error in the stream, it will automatically +-- insert replacement bytes to replace invalid sequences. +-- +-- In the case of sequence that fall in the middle of 2 chunks, +-- the remaining buffer is supposed to be preprended to the +-- next chunk, and resume the parsing. +fromBytesLenient :: UArray Word8 -> (String, UArray Word8) +fromBytesLenient bytes + | C.null bytes = (mempty, mempty) + | otherwise = + case validate bytes (Offset 0) (C.length bytes) of + (_, Nothing) -> (fromBytesUnsafe bytes, mempty) + -- TODO: Should anything be done in the 'BuildingFailure' case? + (_, Just BuildingFailure) -> error "fromBytesLenient: FIXME!" + (pos, Just MissingByte) -> + let (b1,b2) = C.splitAt (offsetAsSize pos) bytes + in (fromBytesUnsafe b1, b2) + (pos, Just InvalidHeader) -> + let (b1,b2) = C.splitAt (offsetAsSize pos) bytes + (_,b3) = C.splitAt 1 b2 + (s3, r) = fromBytesLenient b3 + in (mconcat [fromBytesUnsafe b1,replacement, s3], r) + (pos, Just InvalidContinuation) -> + let (b1,b2) = C.splitAt (offsetAsSize pos) bytes + (_,b3) = C.splitAt 1 b2 + (s3, r) = fromBytesLenient b3 + in (mconcat [fromBytesUnsafe b1,replacement, s3], r) + where + -- This is the replacement character U+FFFD used for any invalid header or continuation + replacement :: String + !replacement = fromBytesUnsafe $ fromList [0xef,0xbf,0xbd] + +-- | Decode a stream of binary chunks containing UTF8 encoding in a list of valid String +-- +-- Chunk not necessarily contains a valid string, as +-- a UTF8 sequence could be split over 2 chunks. +fromChunkBytes :: [UArray Word8] -> [String] +fromChunkBytes l = loop l + where + loop [] = [] + loop [bytes] = + case validate bytes (Offset 0) (C.length bytes) of + (_, Nothing) -> [fromBytesUnsafe bytes] + (_, Just err) -> doErr err + loop (bytes:cs@(c1:c2)) = + case validate bytes (Offset 0) (C.length bytes) of + (_, Nothing) -> fromBytesUnsafe bytes : loop cs + (pos, Just MissingByte) -> + let (b1,b2) = C.splitAt (offsetAsSize pos) bytes + in fromBytesUnsafe b1 : loop ((b2 `mappend` c1) : c2) + (_, Just err) -> doErr err + doErr err = error ("fromChunkBytes: " <> show err) + +-- | Convert a Byte Array representing UTF8 data directly to a string without checking for UTF8 validity +-- +-- If the input contains invalid sequences, it will trigger runtime async errors when processing data. +-- +-- In doubt, use 'fromBytes' +fromBytesUnsafe :: UArray Word8 -> String +fromBytesUnsafe = String + +toEncoderBytes :: ( Encoder.Encoding encoding + , PrimType (Encoder.Unit encoding) + , Exception (Encoder.Error encoding) + ) + => encoding + -> UArray Word8 + -> UArray Word8 +toEncoderBytes enc bytes = Vec.recast $ + case runST $ Encoder.convertFromTo EncoderUTF8 enc bytes of + Left _ -> error "toEncoderBytes: FIXME!" + Right converted -> converted + +-- | Convert a String to a bytearray in a specific encoding +-- +-- if the encoding is UTF8, the underlying buffer is returned without extra allocation or any processing +-- +-- In any other encoding, some allocation and processing are done to convert. +toBytes :: Encoding -> String -> UArray Word8 +toBytes UTF8 (String bytes) = bytes +toBytes ASCII7 (String bytes) = toEncoderBytes Encoder.ASCII7 bytes +toBytes ISO_8859_1 (String bytes) = toEncoderBytes Encoder.ISO_8859_1 bytes +toBytes UTF16 (String bytes) = toEncoderBytes Encoder.UTF16 bytes +toBytes UTF32 (String bytes) = toEncoderBytes Encoder.UTF32 bytes + +-- | Split lines in a string using newline as separation. +-- +-- Note that carriage return preceding a newline are also strip for +-- maximum compatibility between Windows and Unix system. +lines :: String -> [String] +lines s = + case breakLine s of + Left _ -> [s] + Right (line,r) -> line : lines r + +-- | Split words in a string using spaces as separation +-- +-- > words "Hello Foundation" +-- [ "Hello", "Foundation" ] +words :: String -> [String] +words = fmap fromList . Prelude.words . toList + +-- | Append a character to a String builder +builderAppend :: PrimMonad state => Char -> Builder String MutableString Word8 state err () +builderAppend c = Builder $ State $ \(i, st, e) -> + if offsetAsSize i + nbBytes >= chunkSize st + then do + cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i) + newChunk <- new (chunkSize st) + writeUTF8Char newChunk (Offset 0) utf8Char + return ((), (sizeAsOffset nbBytes, st { prevChunks = cur : prevChunks st + , prevChunksSize = offsetAsSize i + prevChunksSize st + , curChunk = newChunk + }, e)) + else do + writeUTF8Char (curChunk st) i utf8Char + return ((), (i + sizeAsOffset nbBytes, st, e)) + where + utf8Char = asUTF8Char c + nbBytes = numBytes utf8Char + +-- | Create a new String builder using chunks of @sizeChunksI@ +builderBuild :: PrimMonad m => Int -> Builder String MutableString Word8 m err () -> m (Either err String) +builderBuild sizeChunksI sb + | sizeChunksI <= 3 = builderBuild 64 sb + | otherwise = do + firstChunk <- new sizeChunks + (i, st, e) <- snd <$> runState (runBuilder sb) (Offset 0, BuildingState [] (CountOf 0) firstChunk sizeChunks, Nothing) + case e of + Just err -> return (Left err) + Nothing -> do + cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i) + -- Build final array + let totalSize = prevChunksSize st + offsetAsSize i + final <- Vec.new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= Vec.unsafeFreeze + return . Right . String $ final + where + sizeChunks = CountOf sizeChunksI + + fillFromEnd _ [] mba = return mba + fillFromEnd !end (String x:xs) mba = do + let sz = Vec.length x + let start = end `sizeSub` sz + Vec.unsafeCopyAtRO mba (sizeAsOffset start) x (Offset 0) sz + fillFromEnd start xs mba + +builderBuild_ :: PrimMonad m => Int -> Builder String MutableString Word8 m () () -> m String +builderBuild_ sizeChunksI sb = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI sb + +stringDewrap :: (Block Word8 -> Offset Word8 -> a) + -> (Ptr Word8 -> Offset Word8 -> ST s a) + -> String + -> a +stringDewrap withBa withPtr (String ba) = C.unsafeDewrap withBa withPtr ba +{-# INLINE stringDewrap #-} + +-- | Read an Integer from a String +-- +-- Consume an optional minus sign and many digits until end of string. +readIntegral :: (HasNegation i, IntegralUpsize Word8 i, Additive i, Multiplicative i, IsIntegral i) => String -> Maybe i +readIntegral str + | sz == 0 = Nothing + | otherwise = stringDewrap withBa (\ptr@(Ptr !_) -> pure . withPtr ptr) str + where + !sz = size str + withBa ba ofs = + let negativeSign = UTF8.expectAscii ba ofs 0x2d + startOfs = if negativeSign then succ ofs else ofs + in case decimalDigitsBA 0 ba endOfs startOfs of + (# acc, True, endOfs' #) | endOfs' > startOfs -> Just $! if negativeSign then negate acc else acc + _ -> Nothing + where !endOfs = ofs `offsetPlusE` sz + withPtr addr ofs = + let negativeSign = UTF8.expectAscii addr ofs 0x2d + startOfs = if negativeSign then succ ofs else ofs + in case decimalDigitsPtr 0 addr endOfs startOfs of + (# acc, True, endOfs' #) | endOfs' > startOfs -> Just $! if negativeSign then negate acc else acc + _ -> Nothing + where !endOfs = ofs `offsetPlusE` sz +{-# SPECIALISE readIntegral :: String -> Maybe Integer #-} +{-# SPECIALISE readIntegral :: String -> Maybe Int #-} + +readInteger :: String -> Maybe Integer +readInteger = readIntegral + +-- | Read a Natural from a String +-- +-- Consume many digits until end of string. +readNatural :: String -> Maybe Natural +readNatural str + | sz == 0 = Nothing + | otherwise = stringDewrap withBa (\ptr@(Ptr !_) -> pure . withPtr ptr) str + where + !sz = size str + withBa ba stringStart = + case decimalDigitsBA 0 ba eofs stringStart of + (# acc, True, endOfs #) | endOfs > stringStart -> Just acc + _ -> Nothing + where eofs = stringStart `offsetPlusE` sz + withPtr addr stringStart = + case decimalDigitsPtr 0 addr eofs stringStart of + (# acc, True, endOfs #) | endOfs > stringStart -> Just acc + _ -> Nothing + where eofs = stringStart `offsetPlusE` sz + +-- | Try to read a Double +readDouble :: String -> Maybe Double +readDouble s = + readFloatingExact s $ \isNegative integral floatingDigits mExponant -> + Just $ applySign isNegative $ case (floatingDigits, mExponant) of + (0, Nothing) -> naturalToDouble integral + (0, Just exponent) -> withExponant exponent $ naturalToDouble integral + (floating, Nothing) -> applyFloating floating $ naturalToDouble integral + (floating, Just exponent) -> withExponant exponent $ applyFloating floating $ naturalToDouble integral + where + applySign True = negate + applySign False = id + withExponant e v = v * doubleExponant 10 e + applyFloating digits n = n / (10 Prelude.^ digits) + +-- | Try to read a floating number as a Rational +-- +-- Note that for safety reason, only exponent between -10000 and 10000 is allowed +-- as otherwise DoS/OOM is very likely. if you don't want this behavior, +-- switching to a scientific type (not provided yet) that represent the +-- exponent separately is the advised solution. +readRational :: String -> Maybe Prelude.Rational +readRational s = + readFloatingExact s $ \isNegative integral floatingDigits mExponant -> + case mExponant of + Just exponent + | exponent < -10000 || exponent > 10000 -> Nothing + | otherwise -> Just $ modF isNegative integral % (10 Prelude.^ (cast floatingDigits - exponent)) + Nothing -> Just $ modF isNegative integral % (10 Prelude.^ floatingDigits) + where + modF True = negate . integralUpsize + modF False = integralUpsize + + +type ReadFloatingCallback a = Bool -- sign + -> Natural -- integral part + -> Word -- number of digits in floating section + -> Maybe Int -- optional integer representing exponent in base 10 + -> Maybe a + +-- | Read an Floating like number of the form: +-- +-- [ '-' ] [ '.' ] [ ( 'e' | 'E' ) [ '-' ] ] +-- +-- Call a function with: +-- +-- * A boolean representing if the number is negative +-- * The digits part represented as a single natural number (123.456 is represented as 123456) +-- * The number of digits in the fractional part (e.g. 123.456 => 3) +-- * The exponent if any +-- +-- The code is structured as a simple state machine that: +-- +-- * Optionally Consume a '-' sign +-- * Consume number for the integral part +-- * Optionally +-- * Consume '.' +-- * Consume remaining digits if not already end of string +-- * Optionally Consume a 'e' or 'E' follow by an optional '-' and a number +-- +readFloatingExact :: String -> ReadFloatingCallback a -> Maybe a +readFloatingExact str f + | sz == 0 = Nothing + | otherwise = stringDewrap withBa withPtr str + where + !sz = size str + + withBa ba stringStart = + let !isNegative = UTF8.expectAscii ba stringStart 0x2d + in consumeIntegral isNegative (if isNegative then stringStart+1 else stringStart) + where + eofs = stringStart `offsetPlusE` sz + consumeIntegral !isNegative startOfs = + case decimalDigitsBA 0 ba eofs startOfs of + (# acc, True , endOfs #) | endOfs > startOfs -> f isNegative acc 0 Nothing -- end of stream and no '.' + (# acc, False, endOfs #) | endOfs > startOfs -> + if UTF8.expectAscii ba endOfs 0x2e + then consumeFloat isNegative acc (endOfs + 1) + else consumeExponant isNegative acc 0 endOfs + _ -> Nothing + + consumeFloat isNegative integral startOfs = + case decimalDigitsBA integral ba eofs startOfs of + (# acc, True, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs - startOfs + in f isNegative acc (cast diff) Nothing + (# acc, False, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs - startOfs + in consumeExponant isNegative acc (cast diff) endOfs + _ -> Nothing + + consumeExponant !isNegative !integral !floatingDigits !startOfs + | startOfs == eofs = f isNegative integral floatingDigits Nothing + | otherwise = + -- consume 'E' or 'e' + case UTF8.nextAscii ba startOfs of + StepASCII 0x45 -> consumeExponantSign (startOfs+1) + StepASCII 0x65 -> consumeExponantSign (startOfs+1) + _ -> Nothing + where + consumeExponantSign ofs + | ofs == eofs = Nothing + | otherwise = let exponentNegative = UTF8.expectAscii ba ofs 0x2d + in consumeExponantNumber exponentNegative (if exponentNegative then ofs + 1 else ofs) + + consumeExponantNumber exponentNegative ofs = + case decimalDigitsBA 0 ba eofs ofs of + (# acc, True, endOfs #) | endOfs > ofs -> f isNegative integral floatingDigits (Just $! if exponentNegative then negate acc else acc) + _ -> Nothing + withPtr ptr@(Ptr !_) stringStart = pure $ + let !isNegative = UTF8.expectAscii ptr stringStart 0x2d + in consumeIntegral isNegative (if isNegative then stringStart+1 else stringStart) + where + eofs = stringStart `offsetPlusE` sz + consumeIntegral !isNegative startOfs = + case decimalDigitsPtr 0 ptr eofs startOfs of + (# acc, True , endOfs #) | endOfs > startOfs -> f isNegative acc 0 Nothing -- end of stream and no '.' + (# acc, False, endOfs #) | endOfs > startOfs -> + if UTF8.expectAscii ptr endOfs 0x2e + then consumeFloat isNegative acc (endOfs + 1) + else consumeExponant isNegative acc 0 endOfs + _ -> Nothing + + consumeFloat isNegative integral startOfs = + case decimalDigitsPtr integral ptr eofs startOfs of + (# acc, True, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs - startOfs + in f isNegative acc (cast diff) Nothing + (# acc, False, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs - startOfs + in consumeExponant isNegative acc (cast diff) endOfs + _ -> Nothing + + consumeExponant !isNegative !integral !floatingDigits !startOfs + | startOfs == eofs = f isNegative integral floatingDigits Nothing + | otherwise = + -- consume 'E' or 'e' + case UTF8.nextAscii ptr startOfs of + StepASCII 0x45 -> consumeExponantSign (startOfs+1) + StepASCII 0x65 -> consumeExponantSign (startOfs+1) + _ -> Nothing + where + consumeExponantSign ofs + | ofs == eofs = Nothing + | otherwise = let exponentNegative = UTF8.expectAscii ptr ofs 0x2d + in consumeExponantNumber exponentNegative (if exponentNegative then ofs + 1 else ofs) + + consumeExponantNumber exponentNegative ofs = + case decimalDigitsPtr 0 ptr eofs ofs of + (# acc, True, endOfs #) | endOfs > ofs -> f isNegative integral floatingDigits (Just $! if exponentNegative then negate acc else acc) + _ -> Nothing + +-- | Take decimal digits and accumulate it in `acc` +-- +-- The loop starts at the offset specified and finish either when: +-- +-- * It reach the end of the string +-- * It reach a non-ASCII character +-- * It reach an ASCII character that is not a digit (0 to 9) +-- +-- Otherwise each iterations: +-- +-- * Transform the ASCII digits into a number +-- * scale the accumulator by 10 +-- * Add the number (between 0 and 9) to the accumulator +-- +-- It then returns: +-- +-- * The new accumulated value +-- * Whether it stop by end of string or not +-- * The end offset when the loop stopped +-- +-- If end offset == start offset then no digits have been consumed by +-- this function +decimalDigitsBA :: (IntegralUpsize Word8 acc, Additive acc, Multiplicative acc, Integral acc) + => acc + -> Block Word8 + -> Offset Word8 -- end offset + -> Offset Word8 -- start offset + -> (# acc, Bool, Offset Word8 #) +decimalDigitsBA startAcc ba !endOfs !startOfs = loop startAcc startOfs + where + loop !acc !ofs + | ofs == endOfs = (# acc, True, ofs #) + | otherwise = + case UTF8.nextAsciiDigit ba ofs of + sg@(StepDigit d) | isValidStepDigit sg -> loop (10 * acc + integralUpsize d) (succ ofs) + | otherwise -> (# acc, False, ofs #) +{-# SPECIALIZE decimalDigitsBA :: Integer -> Block Word8 -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsBA :: Natural -> Block Word8 -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsBA :: Int -> Block Word8 -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsBA :: Word -> Block Word8 -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-} + +-- | same as decimalDigitsBA specialized for ptr # +decimalDigitsPtr :: (IntegralUpsize Word8 acc, Additive acc, Multiplicative acc, Integral acc) + => acc + -> Ptr Word8 + -> Offset Word8 -- end offset + -> Offset Word8 -- start offset + -> (# acc, Bool, Offset Word8 #) +decimalDigitsPtr startAcc ptr !endOfs !startOfs = loop startAcc startOfs + where + loop !acc !ofs + | ofs == endOfs = (# acc, True, ofs #) + | otherwise = + case UTF8.nextAsciiDigit ptr ofs of + sg@(StepDigit d) | isValidStepDigit sg -> loop (10 * acc + integralUpsize d) (succ ofs) + | otherwise -> (# acc, False, ofs #) +{-# SPECIALIZE decimalDigitsPtr :: Integer -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsPtr :: Natural -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsPtr :: Int -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsPtr :: Word -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-} + +-- | Convert a 'String' 'Char' by 'Char' using a case mapping function. +caseConvert :: (Char7 -> Char7) -> (Char -> CM) -> String -> String +caseConvert opASCII op s@(String arr) = runST $ do + mba <- MBLK.new iLen + nL <- C.onBackendPrim + (\blk -> go mba blk (Offset 0) start) + (\fptr -> withFinalPtr fptr $ \ptr -> go mba ptr (Offset 0) start) + arr + freeze . MutableString $ MVec.MUArray 0 nL (C.MUArrayMBA mba) + where + !(C.ValidRange start end) = C.offsetsValidRange arr + !iLen = 1 + C.length arr + go :: (Indexable container Word8, PrimMonad prim) + => MutableBlock Word8 (PrimState prim) + -> container + -> Offset Word8 + -> Offset Word8 + -> prim (CountOf Word8) + go !dst !src = loop dst iLen 0 + where + eSize !e = if e == '\0' then 0 else charToBytes (fromEnum e) + loop !dst !allocLen !nLen !dstIdx !srcIdx + | srcIdx == end = return nLen + | nLen == allocLen = realloc + | headerIsAscii h = do + UTF8.writeASCII dst dstIdx (opASCII $ Char7 $ stepAsciiRawValue h) + loop dst allocLen (nLen + 1) (dstIdx+Offset 1) (srcIdx+Offset 1) + | otherwise = do + let !(CM c1 c2 c3) = op c + !(Step c nextSrcIdx) = UTF8.nextWith h src (srcIdx+Offset 1) + nextDstIdx <- UTF8.writeUTF8 dst dstIdx c1 + if c2 == '\0' -- We keep the most common case loop as short as possible. + then loop dst allocLen (nLen + charToBytes (fromEnum c1)) nextDstIdx nextSrcIdx + else do + let !cSize = eSize c1 + eSize c2 + eSize c3 + nextDstIdx <- UTF8.writeUTF8 dst nextDstIdx c2 + nextDstIdx <- if c3 == '\0' then return nextDstIdx else UTF8.writeUTF8 dst nextDstIdx c3 + loop dst allocLen (nLen + cSize) nextDstIdx nextSrcIdx + where + {-# NOINLINE realloc #-} + realloc = do + let nAll = allocLen + allocLen + 1 + nDst <- MBLK.new nAll + MBLK.unsafeCopyElements nDst 0 dst 0 nLen + loop nDst nAll nLen dstIdx srcIdx + h = UTF8.nextAscii src srcIdx + +-- | Convert a 'String' to the upper-case equivalent. +upper :: String -> String +upper = caseConvert c7Upper upperMapping + +-- | Convert a 'String' to the upper-case equivalent. +lower :: String -> String +lower = caseConvert c7Lower lowerMapping + +-- | Convert a 'String' to the unicode case fold equivalent. +-- +-- Case folding is mostly used for caseless comparison of strings. +caseFold :: String -> String +caseFold = caseConvert c7Upper foldMapping + +-- | Check whether the first string is a prefix of the second string. +isPrefixOf :: String -> String -> Bool +isPrefixOf (String needle) (String haystack) = C.isPrefixOf needle haystack + +-- | Check whether the first string is a suffix of the second string. +isSuffixOf :: String -> String -> Bool +isSuffixOf (String needle) (String haystack) + | needleLen > hayLen = False + | otherwise = needle == C.revTake needleLen haystack + where + needleLen = C.length needle + hayLen = C.length haystack + +-- | Check whether the first string is contains within the second string. +-- +-- TODO: implemented the naive way and thus terribly inefficient, reimplement properly +isInfixOf :: String -> String -> Bool +isInfixOf (String needle) (String haystack) + = loop (hayLen - needleLen) haystack + where + needleLen = C.length needle + hayLen = C.length haystack + loop Nothing _ = False + loop (Just cnt) haystack' = needle == C.take needleLen haystack' || loop (cnt-1) (C.drop 1 haystack') + +-- | Try to strip a prefix from the start of a String. +-- +-- If the prefix is not starting the string, then Nothing is returned, +-- otherwise the striped string is returned +stripPrefix :: String -> String -> Maybe String +stripPrefix (String suffix) (String arr) + | C.isPrefixOf suffix arr = Just $ String $ C.drop (C.length suffix) arr + | otherwise = Nothing + +-- | Try to strip a suffix from the end of a String. +-- +-- If the suffix is not ending the string, then Nothing is returned, +-- otherwise the striped string is returned +stripSuffix :: String -> String -> Maybe String +stripSuffix (String prefix) (String arr) + | C.isSuffixOf prefix arr = Just $ String $ C.revDrop (C.length prefix) arr + | otherwise = Nothing + +all :: (Char -> Bool) -> String -> Bool +all predicate (String arr) = C.onBackend goBA (\_ -> pure . goAddr) arr + where + !(C.ValidRange start end) = C.offsetsValidRange arr + goBA ba = UTF8.all predicate ba start end + goAddr addr = UTF8.all predicate addr start end + +any :: (Char -> Bool) -> String -> Bool +any predicate (String arr) = C.onBackend goBA (\_ -> pure . goAddr) arr + where + !(C.ValidRange start end) = C.offsetsValidRange arr + goBA ba = UTF8.any predicate ba start end + goAddr addr = UTF8.any predicate addr start end + +-- | Transform string @src@ to base64 binary representation. +toBase64 :: String -> String +toBase64 (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ True + where + !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"# + +-- | Transform string @src@ to URL-safe base64 binary representation. +-- The result will be either padded or unpadded, depending on the boolean +-- @padded@ argument. +toBase64URL :: Bool -> String -> String +toBase64URL padded (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ padded + where + !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"# + +-- | Transform string @src@ to OpenBSD base64 binary representation. +toBase64OpenBSD :: String -> String +toBase64OpenBSD (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ False + where + !set = "./ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"# diff --git a/bundled/Basement/String/Builder.hs b/bundled/Basement/String/Builder.hs new file mode 100644 index 0000000..7ef3876 --- /dev/null +++ b/bundled/Basement/String/Builder.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.String.Builder +-- License : BSD-style +-- Maintainer : Foundation +-- +-- String builder + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Basement.String.Builder + ( Builder + , run + , runUnsafe + + -- * Emit functions + , emit + , emitChar + + -- * unsafe + , unsafeStringBuilder + ) where + + +import qualified Basement.Block.Base as Block (length) +import qualified Basement.Block.Builder as Block +import Basement.Compat.Base +import Basement.Compat.Semigroup +import Basement.Monad +import Basement.String (String, ValidationFailure, Encoding (UTF8), fromBytes) +import Basement.UArray.Base (UArray) +import qualified Basement.UArray.Base as A + +newtype Builder = Builder Block.Builder + deriving (Semigroup, Monoid) + +unsafeStringBuilder :: Block.Builder -> Builder +unsafeStringBuilder = Builder +{-# INLINE unsafeStringBuilder #-} + +run :: PrimMonad prim => Builder -> prim (String, Maybe ValidationFailure, UArray Word8) +run (Builder builder) = do + block <- Block.run builder + let array = A.UArray 0 (Block.length block) (A.UArrayBA block) + pure $ fromBytes UTF8 array + +-- | run the given builder and return the generated String +-- +-- prefer `run` +runUnsafe :: PrimMonad prim => Builder -> prim String +runUnsafe (Builder builder) = Block.unsafeRunString builder + +-- | add a string in the builder +emit :: String -> Builder +emit = Builder . Block.emitString + +-- | emit a UTF8 char in the builder +emitChar :: Char -> Builder +emitChar = Builder . Block.emitUTF8Char diff --git a/bundled/Basement/String/CaseMapping.hs b/bundled/Basement/String/CaseMapping.hs new file mode 100644 index 0000000..4be7fb4 --- /dev/null +++ b/bundled/Basement/String/CaseMapping.hs @@ -0,0 +1,3245 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Rank2Types #-} +-- AUTOMATICALLY GENERATED - DO NOT EDIT +-- Generated by scripts/caseMapping/generateCaseMapping.sh +-- CaseFolding-10.0.0.txt +-- Date: 2017-04-14, 05:40:18 GMT +-- SpecialCasing-10.0.0.txt +-- Date: 2017-04-14, 05:40:43 GMT + +module Basement.String.CaseMapping where + +import Data.Char +import Basement.UTF8.Types + +upperMapping :: Char -> CM +{-# NOINLINE upperMapping #-} +-- LATIN SMALL LETTER SHARP S +upperMapping '\x00DF' = CM '\x0053' '\x0053' '\0' +-- LATIN SMALL LIGATURE FF +upperMapping '\xFB00' = CM '\x0046' '\x0046' '\0' +-- LATIN SMALL LIGATURE FI +upperMapping '\xFB01' = CM '\x0046' '\x0049' '\0' +-- LATIN SMALL LIGATURE FL +upperMapping '\xFB02' = CM '\x0046' '\x004C' '\0' +-- LATIN SMALL LIGATURE FFI +upperMapping '\xFB03' = CM '\x0046' '\x0046' '\x0049' +-- LATIN SMALL LIGATURE FFL +upperMapping '\xFB04' = CM '\x0046' '\x0046' '\x004C' +-- LATIN SMALL LIGATURE LONG S T +upperMapping '\xFB05' = CM '\x0053' '\x0054' '\0' +-- LATIN SMALL LIGATURE ST +upperMapping '\xFB06' = CM '\x0053' '\x0054' '\0' +-- ARMENIAN SMALL LIGATURE ECH YIWN +upperMapping '\x0587' = CM '\x0535' '\x0552' '\0' +-- ARMENIAN SMALL LIGATURE MEN NOW +upperMapping '\xFB13' = CM '\x0544' '\x0546' '\0' +-- ARMENIAN SMALL LIGATURE MEN ECH +upperMapping '\xFB14' = CM '\x0544' '\x0535' '\0' +-- ARMENIAN SMALL LIGATURE MEN INI +upperMapping '\xFB15' = CM '\x0544' '\x053B' '\0' +-- ARMENIAN SMALL LIGATURE VEW NOW +upperMapping '\xFB16' = CM '\x054E' '\x0546' '\0' +-- ARMENIAN SMALL LIGATURE MEN XEH +upperMapping '\xFB17' = CM '\x0544' '\x053D' '\0' +-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE +upperMapping '\x0149' = CM '\x02BC' '\x004E' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS +upperMapping '\x0390' = CM '\x0399' '\x0308' '\x0301' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS +upperMapping '\x03B0' = CM '\x03A5' '\x0308' '\x0301' +-- LATIN SMALL LETTER J WITH CARON +upperMapping '\x01F0' = CM '\x004A' '\x030C' '\0' +-- LATIN SMALL LETTER H WITH LINE BELOW +upperMapping '\x1E96' = CM '\x0048' '\x0331' '\0' +-- LATIN SMALL LETTER T WITH DIAERESIS +upperMapping '\x1E97' = CM '\x0054' '\x0308' '\0' +-- LATIN SMALL LETTER W WITH RING ABOVE +upperMapping '\x1E98' = CM '\x0057' '\x030A' '\0' +-- LATIN SMALL LETTER Y WITH RING ABOVE +upperMapping '\x1E99' = CM '\x0059' '\x030A' '\0' +-- LATIN SMALL LETTER A WITH RIGHT HALF RING +upperMapping '\x1E9A' = CM '\x0041' '\x02BE' '\0' +-- GREEK SMALL LETTER UPSILON WITH PSILI +upperMapping '\x1F50' = CM '\x03A5' '\x0313' '\0' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA +upperMapping '\x1F52' = CM '\x03A5' '\x0313' '\x0300' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA +upperMapping '\x1F54' = CM '\x03A5' '\x0313' '\x0301' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI +upperMapping '\x1F56' = CM '\x03A5' '\x0313' '\x0342' +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI +upperMapping '\x1FB6' = CM '\x0391' '\x0342' '\0' +-- GREEK SMALL LETTER ETA WITH PERISPOMENI +upperMapping '\x1FC6' = CM '\x0397' '\x0342' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA +upperMapping '\x1FD2' = CM '\x0399' '\x0308' '\x0300' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA +upperMapping '\x1FD3' = CM '\x0399' '\x0308' '\x0301' +-- GREEK SMALL LETTER IOTA WITH PERISPOMENI +upperMapping '\x1FD6' = CM '\x0399' '\x0342' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI +upperMapping '\x1FD7' = CM '\x0399' '\x0308' '\x0342' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA +upperMapping '\x1FE2' = CM '\x03A5' '\x0308' '\x0300' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA +upperMapping '\x1FE3' = CM '\x03A5' '\x0308' '\x0301' +-- GREEK SMALL LETTER RHO WITH PSILI +upperMapping '\x1FE4' = CM '\x03A1' '\x0313' '\0' +-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI +upperMapping '\x1FE6' = CM '\x03A5' '\x0342' '\0' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI +upperMapping '\x1FE7' = CM '\x03A5' '\x0308' '\x0342' +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI +upperMapping '\x1FF6' = CM '\x03A9' '\x0342' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI +upperMapping '\x1F80' = CM '\x1F08' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI +upperMapping '\x1F81' = CM '\x1F09' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1F82' = CM '\x1F0A' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1F83' = CM '\x1F0B' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1F84' = CM '\x1F0C' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1F85' = CM '\x1F0D' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1F86' = CM '\x1F0E' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1F87' = CM '\x1F0F' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI +upperMapping '\x1F88' = CM '\x1F08' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI +upperMapping '\x1F89' = CM '\x1F09' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1F8A' = CM '\x1F0A' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1F8B' = CM '\x1F0B' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1F8C' = CM '\x1F0C' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1F8D' = CM '\x1F0D' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1F8E' = CM '\x1F0E' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1F8F' = CM '\x1F0F' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI +upperMapping '\x1F90' = CM '\x1F28' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI +upperMapping '\x1F91' = CM '\x1F29' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1F92' = CM '\x1F2A' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1F93' = CM '\x1F2B' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1F94' = CM '\x1F2C' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1F95' = CM '\x1F2D' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1F96' = CM '\x1F2E' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1F97' = CM '\x1F2F' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI +upperMapping '\x1F98' = CM '\x1F28' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI +upperMapping '\x1F99' = CM '\x1F29' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1F9A' = CM '\x1F2A' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1F9B' = CM '\x1F2B' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1F9C' = CM '\x1F2C' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1F9D' = CM '\x1F2D' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1F9E' = CM '\x1F2E' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1F9F' = CM '\x1F2F' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI +upperMapping '\x1FA0' = CM '\x1F68' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI +upperMapping '\x1FA1' = CM '\x1F69' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1FA2' = CM '\x1F6A' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1FA3' = CM '\x1F6B' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1FA4' = CM '\x1F6C' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1FA5' = CM '\x1F6D' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1FA6' = CM '\x1F6E' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1FA7' = CM '\x1F6F' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI +upperMapping '\x1FA8' = CM '\x1F68' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI +upperMapping '\x1FA9' = CM '\x1F69' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1FAA' = CM '\x1F6A' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1FAB' = CM '\x1F6B' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1FAC' = CM '\x1F6C' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1FAD' = CM '\x1F6D' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1FAE' = CM '\x1F6E' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1FAF' = CM '\x1F6F' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI +upperMapping '\x1FB3' = CM '\x0391' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI +upperMapping '\x1FBC' = CM '\x0391' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI +upperMapping '\x1FC3' = CM '\x0397' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI +upperMapping '\x1FCC' = CM '\x0397' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI +upperMapping '\x1FF3' = CM '\x03A9' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI +upperMapping '\x1FFC' = CM '\x03A9' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI +upperMapping '\x1FB2' = CM '\x1FBA' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI +upperMapping '\x1FB4' = CM '\x0386' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI +upperMapping '\x1FC2' = CM '\x1FCA' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI +upperMapping '\x1FC4' = CM '\x0389' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI +upperMapping '\x1FF2' = CM '\x1FFA' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI +upperMapping '\x1FF4' = CM '\x038F' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1FB7' = CM '\x0391' '\x0342' '\x0399' +-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1FC7' = CM '\x0397' '\x0342' '\x0399' +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1FF7' = CM '\x03A9' '\x0342' '\x0399' +upperMapping c = CM (toUpper c) '\0' '\0' + +lowerMapping :: Char -> CM +{-# NOINLINE lowerMapping #-} +-- LATIN CAPITAL LETTER I WITH DOT ABOVE +lowerMapping '\x0130' = CM '\x0069' '\x0307' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI +lowerMapping '\x1F88' = CM '\x1F80' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI +lowerMapping '\x1F89' = CM '\x1F81' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI +lowerMapping '\x1F8A' = CM '\x1F82' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI +lowerMapping '\x1F8B' = CM '\x1F83' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI +lowerMapping '\x1F8C' = CM '\x1F84' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI +lowerMapping '\x1F8D' = CM '\x1F85' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +lowerMapping '\x1F8E' = CM '\x1F86' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +lowerMapping '\x1F8F' = CM '\x1F87' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI +lowerMapping '\x1F98' = CM '\x1F90' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI +lowerMapping '\x1F99' = CM '\x1F91' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI +lowerMapping '\x1F9A' = CM '\x1F92' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI +lowerMapping '\x1F9B' = CM '\x1F93' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI +lowerMapping '\x1F9C' = CM '\x1F94' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI +lowerMapping '\x1F9D' = CM '\x1F95' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +lowerMapping '\x1F9E' = CM '\x1F96' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +lowerMapping '\x1F9F' = CM '\x1F97' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI +lowerMapping '\x1FA8' = CM '\x1FA0' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI +lowerMapping '\x1FA9' = CM '\x1FA1' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI +lowerMapping '\x1FAA' = CM '\x1FA2' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI +lowerMapping '\x1FAB' = CM '\x1FA3' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI +lowerMapping '\x1FAC' = CM '\x1FA4' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI +lowerMapping '\x1FAD' = CM '\x1FA5' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +lowerMapping '\x1FAE' = CM '\x1FA6' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +lowerMapping '\x1FAF' = CM '\x1FA7' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI +lowerMapping '\x1FBC' = CM '\x1FB3' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI +lowerMapping '\x1FCC' = CM '\x1FC3' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI +lowerMapping '\x1FFC' = CM '\x1FF3' '\0' '\0' +lowerMapping c = CM (toLower c) '\0' '\0' + +titleMapping :: Char -> CM +{-# NOINLINE titleMapping #-} +-- LATIN SMALL LETTER SHARP S +titleMapping '\x00DF' = CM '\x0053' '\x0073' '\0' +-- LATIN SMALL LIGATURE FF +titleMapping '\xFB00' = CM '\x0046' '\x0066' '\0' +-- LATIN SMALL LIGATURE FI +titleMapping '\xFB01' = CM '\x0046' '\x0069' '\0' +-- LATIN SMALL LIGATURE FL +titleMapping '\xFB02' = CM '\x0046' '\x006C' '\0' +-- LATIN SMALL LIGATURE FFI +titleMapping '\xFB03' = CM '\x0046' '\x0066' '\x0069' +-- LATIN SMALL LIGATURE FFL +titleMapping '\xFB04' = CM '\x0046' '\x0066' '\x006C' +-- LATIN SMALL LIGATURE LONG S T +titleMapping '\xFB05' = CM '\x0053' '\x0074' '\0' +-- LATIN SMALL LIGATURE ST +titleMapping '\xFB06' = CM '\x0053' '\x0074' '\0' +-- ARMENIAN SMALL LIGATURE ECH YIWN +titleMapping '\x0587' = CM '\x0535' '\x0582' '\0' +-- ARMENIAN SMALL LIGATURE MEN NOW +titleMapping '\xFB13' = CM '\x0544' '\x0576' '\0' +-- ARMENIAN SMALL LIGATURE MEN ECH +titleMapping '\xFB14' = CM '\x0544' '\x0565' '\0' +-- ARMENIAN SMALL LIGATURE MEN INI +titleMapping '\xFB15' = CM '\x0544' '\x056B' '\0' +-- ARMENIAN SMALL LIGATURE VEW NOW +titleMapping '\xFB16' = CM '\x054E' '\x0576' '\0' +-- ARMENIAN SMALL LIGATURE MEN XEH +titleMapping '\xFB17' = CM '\x0544' '\x056D' '\0' +-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE +titleMapping '\x0149' = CM '\x02BC' '\x004E' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS +titleMapping '\x0390' = CM '\x0399' '\x0308' '\x0301' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS +titleMapping '\x03B0' = CM '\x03A5' '\x0308' '\x0301' +-- LATIN SMALL LETTER J WITH CARON +titleMapping '\x01F0' = CM '\x004A' '\x030C' '\0' +-- LATIN SMALL LETTER H WITH LINE BELOW +titleMapping '\x1E96' = CM '\x0048' '\x0331' '\0' +-- LATIN SMALL LETTER T WITH DIAERESIS +titleMapping '\x1E97' = CM '\x0054' '\x0308' '\0' +-- LATIN SMALL LETTER W WITH RING ABOVE +titleMapping '\x1E98' = CM '\x0057' '\x030A' '\0' +-- LATIN SMALL LETTER Y WITH RING ABOVE +titleMapping '\x1E99' = CM '\x0059' '\x030A' '\0' +-- LATIN SMALL LETTER A WITH RIGHT HALF RING +titleMapping '\x1E9A' = CM '\x0041' '\x02BE' '\0' +-- GREEK SMALL LETTER UPSILON WITH PSILI +titleMapping '\x1F50' = CM '\x03A5' '\x0313' '\0' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA +titleMapping '\x1F52' = CM '\x03A5' '\x0313' '\x0300' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA +titleMapping '\x1F54' = CM '\x03A5' '\x0313' '\x0301' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI +titleMapping '\x1F56' = CM '\x03A5' '\x0313' '\x0342' +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI +titleMapping '\x1FB6' = CM '\x0391' '\x0342' '\0' +-- GREEK SMALL LETTER ETA WITH PERISPOMENI +titleMapping '\x1FC6' = CM '\x0397' '\x0342' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA +titleMapping '\x1FD2' = CM '\x0399' '\x0308' '\x0300' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA +titleMapping '\x1FD3' = CM '\x0399' '\x0308' '\x0301' +-- GREEK SMALL LETTER IOTA WITH PERISPOMENI +titleMapping '\x1FD6' = CM '\x0399' '\x0342' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI +titleMapping '\x1FD7' = CM '\x0399' '\x0308' '\x0342' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA +titleMapping '\x1FE2' = CM '\x03A5' '\x0308' '\x0300' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA +titleMapping '\x1FE3' = CM '\x03A5' '\x0308' '\x0301' +-- GREEK SMALL LETTER RHO WITH PSILI +titleMapping '\x1FE4' = CM '\x03A1' '\x0313' '\0' +-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI +titleMapping '\x1FE6' = CM '\x03A5' '\x0342' '\0' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI +titleMapping '\x1FE7' = CM '\x03A5' '\x0308' '\x0342' +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI +titleMapping '\x1FF6' = CM '\x03A9' '\x0342' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI +titleMapping '\x1F80' = CM '\x1F88' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI +titleMapping '\x1F81' = CM '\x1F89' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI +titleMapping '\x1F82' = CM '\x1F8A' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI +titleMapping '\x1F83' = CM '\x1F8B' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI +titleMapping '\x1F84' = CM '\x1F8C' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI +titleMapping '\x1F85' = CM '\x1F8D' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1F86' = CM '\x1F8E' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1F87' = CM '\x1F8F' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI +titleMapping '\x1F90' = CM '\x1F98' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI +titleMapping '\x1F91' = CM '\x1F99' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI +titleMapping '\x1F92' = CM '\x1F9A' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI +titleMapping '\x1F93' = CM '\x1F9B' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI +titleMapping '\x1F94' = CM '\x1F9C' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI +titleMapping '\x1F95' = CM '\x1F9D' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1F96' = CM '\x1F9E' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1F97' = CM '\x1F9F' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI +titleMapping '\x1FA0' = CM '\x1FA8' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI +titleMapping '\x1FA1' = CM '\x1FA9' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI +titleMapping '\x1FA2' = CM '\x1FAA' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI +titleMapping '\x1FA3' = CM '\x1FAB' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI +titleMapping '\x1FA4' = CM '\x1FAC' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI +titleMapping '\x1FA5' = CM '\x1FAD' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1FA6' = CM '\x1FAE' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1FA7' = CM '\x1FAF' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI +titleMapping '\x1FB3' = CM '\x1FBC' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI +titleMapping '\x1FC3' = CM '\x1FCC' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI +titleMapping '\x1FF3' = CM '\x1FFC' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI +titleMapping '\x1FB2' = CM '\x1FBA' '\x0345' '\0' +-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI +titleMapping '\x1FB4' = CM '\x0386' '\x0345' '\0' +-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI +titleMapping '\x1FC2' = CM '\x1FCA' '\x0345' '\0' +-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI +titleMapping '\x1FC4' = CM '\x0389' '\x0345' '\0' +-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI +titleMapping '\x1FF2' = CM '\x1FFA' '\x0345' '\0' +-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI +titleMapping '\x1FF4' = CM '\x038F' '\x0345' '\0' +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1FB7' = CM '\x0391' '\x0342' '\x0345' +-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1FC7' = CM '\x0397' '\x0342' '\x0345' +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1FF7' = CM '\x03A9' '\x0342' '\x0345' +titleMapping c = CM (toTitle c) '\0' '\0' + +foldMapping :: Char -> CM +{-# NOINLINE foldMapping #-} +-- LATIN CAPITAL LETTER A +foldMapping '\x0041' = CM '\x0061' '\0' '\0' +-- LATIN CAPITAL LETTER B +foldMapping '\x0042' = CM '\x0062' '\0' '\0' +-- LATIN CAPITAL LETTER C +foldMapping '\x0043' = CM '\x0063' '\0' '\0' +-- LATIN CAPITAL LETTER D +foldMapping '\x0044' = CM '\x0064' '\0' '\0' +-- LATIN CAPITAL LETTER E +foldMapping '\x0045' = CM '\x0065' '\0' '\0' +-- LATIN CAPITAL LETTER F +foldMapping '\x0046' = CM '\x0066' '\0' '\0' +-- LATIN CAPITAL LETTER G +foldMapping '\x0047' = CM '\x0067' '\0' '\0' +-- LATIN CAPITAL LETTER H +foldMapping '\x0048' = CM '\x0068' '\0' '\0' +-- LATIN CAPITAL LETTER I +foldMapping '\x0049' = CM '\x0069' '\0' '\0' +-- LATIN CAPITAL LETTER J +foldMapping '\x004A' = CM '\x006A' '\0' '\0' +-- LATIN CAPITAL LETTER K +foldMapping '\x004B' = CM '\x006B' '\0' '\0' +-- LATIN CAPITAL LETTER L +foldMapping '\x004C' = CM '\x006C' '\0' '\0' +-- LATIN CAPITAL LETTER M +foldMapping '\x004D' = CM '\x006D' '\0' '\0' +-- LATIN CAPITAL LETTER N +foldMapping '\x004E' = CM '\x006E' '\0' '\0' +-- LATIN CAPITAL LETTER O +foldMapping '\x004F' = CM '\x006F' '\0' '\0' +-- LATIN CAPITAL LETTER P +foldMapping '\x0050' = CM '\x0070' '\0' '\0' +-- LATIN CAPITAL LETTER Q +foldMapping '\x0051' = CM '\x0071' '\0' '\0' +-- LATIN CAPITAL LETTER R +foldMapping '\x0052' = CM '\x0072' '\0' '\0' +-- LATIN CAPITAL LETTER S +foldMapping '\x0053' = CM '\x0073' '\0' '\0' +-- LATIN CAPITAL LETTER T +foldMapping '\x0054' = CM '\x0074' '\0' '\0' +-- LATIN CAPITAL LETTER U +foldMapping '\x0055' = CM '\x0075' '\0' '\0' +-- LATIN CAPITAL LETTER V +foldMapping '\x0056' = CM '\x0076' '\0' '\0' +-- LATIN CAPITAL LETTER W +foldMapping '\x0057' = CM '\x0077' '\0' '\0' +-- LATIN CAPITAL LETTER X +foldMapping '\x0058' = CM '\x0078' '\0' '\0' +-- LATIN CAPITAL LETTER Y +foldMapping '\x0059' = CM '\x0079' '\0' '\0' +-- LATIN CAPITAL LETTER Z +foldMapping '\x005A' = CM '\x007A' '\0' '\0' +-- MICRO SIGN +foldMapping '\x00B5' = CM '\x03BC' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH GRAVE +foldMapping '\x00C0' = CM '\x00E0' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH ACUTE +foldMapping '\x00C1' = CM '\x00E1' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH CIRCUMFLEX +foldMapping '\x00C2' = CM '\x00E2' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH TILDE +foldMapping '\x00C3' = CM '\x00E3' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH DIAERESIS +foldMapping '\x00C4' = CM '\x00E4' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH RING ABOVE +foldMapping '\x00C5' = CM '\x00E5' '\0' '\0' +-- LATIN CAPITAL LETTER AE +foldMapping '\x00C6' = CM '\x00E6' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH CEDILLA +foldMapping '\x00C7' = CM '\x00E7' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH GRAVE +foldMapping '\x00C8' = CM '\x00E8' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH ACUTE +foldMapping '\x00C9' = CM '\x00E9' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CIRCUMFLEX +foldMapping '\x00CA' = CM '\x00EA' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH DIAERESIS +foldMapping '\x00CB' = CM '\x00EB' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH GRAVE +foldMapping '\x00CC' = CM '\x00EC' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH ACUTE +foldMapping '\x00CD' = CM '\x00ED' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH CIRCUMFLEX +foldMapping '\x00CE' = CM '\x00EE' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH DIAERESIS +foldMapping '\x00CF' = CM '\x00EF' '\0' '\0' +-- LATIN CAPITAL LETTER ETH +foldMapping '\x00D0' = CM '\x00F0' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH TILDE +foldMapping '\x00D1' = CM '\x00F1' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH GRAVE +foldMapping '\x00D2' = CM '\x00F2' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH ACUTE +foldMapping '\x00D3' = CM '\x00F3' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH CIRCUMFLEX +foldMapping '\x00D4' = CM '\x00F4' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH TILDE +foldMapping '\x00D5' = CM '\x00F5' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH DIAERESIS +foldMapping '\x00D6' = CM '\x00F6' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH STROKE +foldMapping '\x00D8' = CM '\x00F8' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH GRAVE +foldMapping '\x00D9' = CM '\x00F9' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH ACUTE +foldMapping '\x00DA' = CM '\x00FA' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH CIRCUMFLEX +foldMapping '\x00DB' = CM '\x00FB' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DIAERESIS +foldMapping '\x00DC' = CM '\x00FC' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH ACUTE +foldMapping '\x00DD' = CM '\x00FD' '\0' '\0' +-- LATIN CAPITAL LETTER THORN +foldMapping '\x00DE' = CM '\x00FE' '\0' '\0' +-- LATIN SMALL LETTER SHARP S +foldMapping '\x00DF' = CM '\x0073' '\x0073' '\0' +-- LATIN CAPITAL LETTER A WITH MACRON +foldMapping '\x0100' = CM '\x0101' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH BREVE +foldMapping '\x0102' = CM '\x0103' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH OGONEK +foldMapping '\x0104' = CM '\x0105' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH ACUTE +foldMapping '\x0106' = CM '\x0107' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH CIRCUMFLEX +foldMapping '\x0108' = CM '\x0109' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH DOT ABOVE +foldMapping '\x010A' = CM '\x010B' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH CARON +foldMapping '\x010C' = CM '\x010D' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH CARON +foldMapping '\x010E' = CM '\x010F' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH STROKE +foldMapping '\x0110' = CM '\x0111' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH MACRON +foldMapping '\x0112' = CM '\x0113' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH BREVE +foldMapping '\x0114' = CM '\x0115' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH DOT ABOVE +foldMapping '\x0116' = CM '\x0117' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH OGONEK +foldMapping '\x0118' = CM '\x0119' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CARON +foldMapping '\x011A' = CM '\x011B' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH CIRCUMFLEX +foldMapping '\x011C' = CM '\x011D' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH BREVE +foldMapping '\x011E' = CM '\x011F' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH DOT ABOVE +foldMapping '\x0120' = CM '\x0121' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH CEDILLA +foldMapping '\x0122' = CM '\x0123' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH CIRCUMFLEX +foldMapping '\x0124' = CM '\x0125' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH STROKE +foldMapping '\x0126' = CM '\x0127' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH TILDE +foldMapping '\x0128' = CM '\x0129' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH MACRON +foldMapping '\x012A' = CM '\x012B' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH BREVE +foldMapping '\x012C' = CM '\x012D' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH OGONEK +foldMapping '\x012E' = CM '\x012F' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH DOT ABOVE +foldMapping '\x0130' = CM '\x0069' '\x0307' '\0' +-- LATIN CAPITAL LIGATURE IJ +foldMapping '\x0132' = CM '\x0133' '\0' '\0' +-- LATIN CAPITAL LETTER J WITH CIRCUMFLEX +foldMapping '\x0134' = CM '\x0135' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH CEDILLA +foldMapping '\x0136' = CM '\x0137' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH ACUTE +foldMapping '\x0139' = CM '\x013A' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH CEDILLA +foldMapping '\x013B' = CM '\x013C' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH CARON +foldMapping '\x013D' = CM '\x013E' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH MIDDLE DOT +foldMapping '\x013F' = CM '\x0140' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH STROKE +foldMapping '\x0141' = CM '\x0142' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH ACUTE +foldMapping '\x0143' = CM '\x0144' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH CEDILLA +foldMapping '\x0145' = CM '\x0146' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH CARON +foldMapping '\x0147' = CM '\x0148' '\0' '\0' +-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE +foldMapping '\x0149' = CM '\x02BC' '\x006E' '\0' +-- LATIN CAPITAL LETTER ENG +foldMapping '\x014A' = CM '\x014B' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH MACRON +foldMapping '\x014C' = CM '\x014D' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH BREVE +foldMapping '\x014E' = CM '\x014F' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH DOUBLE ACUTE +foldMapping '\x0150' = CM '\x0151' '\0' '\0' +-- LATIN CAPITAL LIGATURE OE +foldMapping '\x0152' = CM '\x0153' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH ACUTE +foldMapping '\x0154' = CM '\x0155' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH CEDILLA +foldMapping '\x0156' = CM '\x0157' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH CARON +foldMapping '\x0158' = CM '\x0159' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH ACUTE +foldMapping '\x015A' = CM '\x015B' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH CIRCUMFLEX +foldMapping '\x015C' = CM '\x015D' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH CEDILLA +foldMapping '\x015E' = CM '\x015F' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH CARON +foldMapping '\x0160' = CM '\x0161' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH CEDILLA +foldMapping '\x0162' = CM '\x0163' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH CARON +foldMapping '\x0164' = CM '\x0165' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH STROKE +foldMapping '\x0166' = CM '\x0167' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH TILDE +foldMapping '\x0168' = CM '\x0169' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH MACRON +foldMapping '\x016A' = CM '\x016B' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH BREVE +foldMapping '\x016C' = CM '\x016D' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH RING ABOVE +foldMapping '\x016E' = CM '\x016F' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DOUBLE ACUTE +foldMapping '\x0170' = CM '\x0171' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH OGONEK +foldMapping '\x0172' = CM '\x0173' '\0' '\0' +-- LATIN CAPITAL LETTER W WITH CIRCUMFLEX +foldMapping '\x0174' = CM '\x0175' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH CIRCUMFLEX +foldMapping '\x0176' = CM '\x0177' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH DIAERESIS +foldMapping '\x0178' = CM '\x00FF' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH ACUTE +foldMapping '\x0179' = CM '\x017A' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH DOT ABOVE +foldMapping '\x017B' = CM '\x017C' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH CARON +foldMapping '\x017D' = CM '\x017E' '\0' '\0' +-- LATIN SMALL LETTER LONG S +foldMapping '\x017F' = CM '\x0073' '\0' '\0' +-- LATIN CAPITAL LETTER B WITH HOOK +foldMapping '\x0181' = CM '\x0253' '\0' '\0' +-- LATIN CAPITAL LETTER B WITH TOPBAR +foldMapping '\x0182' = CM '\x0183' '\0' '\0' +-- LATIN CAPITAL LETTER TONE SIX +foldMapping '\x0184' = CM '\x0185' '\0' '\0' +-- LATIN CAPITAL LETTER OPEN O +foldMapping '\x0186' = CM '\x0254' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH HOOK +foldMapping '\x0187' = CM '\x0188' '\0' '\0' +-- LATIN CAPITAL LETTER AFRICAN D +foldMapping '\x0189' = CM '\x0256' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH HOOK +foldMapping '\x018A' = CM '\x0257' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH TOPBAR +foldMapping '\x018B' = CM '\x018C' '\0' '\0' +-- LATIN CAPITAL LETTER REVERSED E +foldMapping '\x018E' = CM '\x01DD' '\0' '\0' +-- LATIN CAPITAL LETTER SCHWA +foldMapping '\x018F' = CM '\x0259' '\0' '\0' +-- LATIN CAPITAL LETTER OPEN E +foldMapping '\x0190' = CM '\x025B' '\0' '\0' +-- LATIN CAPITAL LETTER F WITH HOOK +foldMapping '\x0191' = CM '\x0192' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH HOOK +foldMapping '\x0193' = CM '\x0260' '\0' '\0' +-- LATIN CAPITAL LETTER GAMMA +foldMapping '\x0194' = CM '\x0263' '\0' '\0' +-- LATIN CAPITAL LETTER IOTA +foldMapping '\x0196' = CM '\x0269' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH STROKE +foldMapping '\x0197' = CM '\x0268' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH HOOK +foldMapping '\x0198' = CM '\x0199' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED M +foldMapping '\x019C' = CM '\x026F' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH LEFT HOOK +foldMapping '\x019D' = CM '\x0272' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH MIDDLE TILDE +foldMapping '\x019F' = CM '\x0275' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH HORN +foldMapping '\x01A0' = CM '\x01A1' '\0' '\0' +-- LATIN CAPITAL LETTER OI +foldMapping '\x01A2' = CM '\x01A3' '\0' '\0' +-- LATIN CAPITAL LETTER P WITH HOOK +foldMapping '\x01A4' = CM '\x01A5' '\0' '\0' +-- LATIN LETTER YR +foldMapping '\x01A6' = CM '\x0280' '\0' '\0' +-- LATIN CAPITAL LETTER TONE TWO +foldMapping '\x01A7' = CM '\x01A8' '\0' '\0' +-- LATIN CAPITAL LETTER ESH +foldMapping '\x01A9' = CM '\x0283' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH HOOK +foldMapping '\x01AC' = CM '\x01AD' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH RETROFLEX HOOK +foldMapping '\x01AE' = CM '\x0288' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH HORN +foldMapping '\x01AF' = CM '\x01B0' '\0' '\0' +-- LATIN CAPITAL LETTER UPSILON +foldMapping '\x01B1' = CM '\x028A' '\0' '\0' +-- LATIN CAPITAL LETTER V WITH HOOK +foldMapping '\x01B2' = CM '\x028B' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH HOOK +foldMapping '\x01B3' = CM '\x01B4' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH STROKE +foldMapping '\x01B5' = CM '\x01B6' '\0' '\0' +-- LATIN CAPITAL LETTER EZH +foldMapping '\x01B7' = CM '\x0292' '\0' '\0' +-- LATIN CAPITAL LETTER EZH REVERSED +foldMapping '\x01B8' = CM '\x01B9' '\0' '\0' +-- LATIN CAPITAL LETTER TONE FIVE +foldMapping '\x01BC' = CM '\x01BD' '\0' '\0' +-- LATIN CAPITAL LETTER DZ WITH CARON +foldMapping '\x01C4' = CM '\x01C6' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON +foldMapping '\x01C5' = CM '\x01C6' '\0' '\0' +-- LATIN CAPITAL LETTER LJ +foldMapping '\x01C7' = CM '\x01C9' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH SMALL LETTER J +foldMapping '\x01C8' = CM '\x01C9' '\0' '\0' +-- LATIN CAPITAL LETTER NJ +foldMapping '\x01CA' = CM '\x01CC' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH SMALL LETTER J +foldMapping '\x01CB' = CM '\x01CC' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH CARON +foldMapping '\x01CD' = CM '\x01CE' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH CARON +foldMapping '\x01CF' = CM '\x01D0' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH CARON +foldMapping '\x01D1' = CM '\x01D2' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH CARON +foldMapping '\x01D3' = CM '\x01D4' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON +foldMapping '\x01D5' = CM '\x01D6' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE +foldMapping '\x01D7' = CM '\x01D8' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON +foldMapping '\x01D9' = CM '\x01DA' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE +foldMapping '\x01DB' = CM '\x01DC' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON +foldMapping '\x01DE' = CM '\x01DF' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON +foldMapping '\x01E0' = CM '\x01E1' '\0' '\0' +-- LATIN CAPITAL LETTER AE WITH MACRON +foldMapping '\x01E2' = CM '\x01E3' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH STROKE +foldMapping '\x01E4' = CM '\x01E5' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH CARON +foldMapping '\x01E6' = CM '\x01E7' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH CARON +foldMapping '\x01E8' = CM '\x01E9' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH OGONEK +foldMapping '\x01EA' = CM '\x01EB' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH OGONEK AND MACRON +foldMapping '\x01EC' = CM '\x01ED' '\0' '\0' +-- LATIN CAPITAL LETTER EZH WITH CARON +foldMapping '\x01EE' = CM '\x01EF' '\0' '\0' +-- LATIN SMALL LETTER J WITH CARON +foldMapping '\x01F0' = CM '\x006A' '\x030C' '\0' +-- LATIN CAPITAL LETTER DZ +foldMapping '\x01F1' = CM '\x01F3' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH SMALL LETTER Z +foldMapping '\x01F2' = CM '\x01F3' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH ACUTE +foldMapping '\x01F4' = CM '\x01F5' '\0' '\0' +-- LATIN CAPITAL LETTER HWAIR +foldMapping '\x01F6' = CM '\x0195' '\0' '\0' +-- LATIN CAPITAL LETTER WYNN +foldMapping '\x01F7' = CM '\x01BF' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH GRAVE +foldMapping '\x01F8' = CM '\x01F9' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE +foldMapping '\x01FA' = CM '\x01FB' '\0' '\0' +-- LATIN CAPITAL LETTER AE WITH ACUTE +foldMapping '\x01FC' = CM '\x01FD' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH STROKE AND ACUTE +foldMapping '\x01FE' = CM '\x01FF' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH DOUBLE GRAVE +foldMapping '\x0200' = CM '\x0201' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH INVERTED BREVE +foldMapping '\x0202' = CM '\x0203' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH DOUBLE GRAVE +foldMapping '\x0204' = CM '\x0205' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH INVERTED BREVE +foldMapping '\x0206' = CM '\x0207' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH DOUBLE GRAVE +foldMapping '\x0208' = CM '\x0209' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH INVERTED BREVE +foldMapping '\x020A' = CM '\x020B' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH DOUBLE GRAVE +foldMapping '\x020C' = CM '\x020D' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH INVERTED BREVE +foldMapping '\x020E' = CM '\x020F' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH DOUBLE GRAVE +foldMapping '\x0210' = CM '\x0211' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH INVERTED BREVE +foldMapping '\x0212' = CM '\x0213' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DOUBLE GRAVE +foldMapping '\x0214' = CM '\x0215' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH INVERTED BREVE +foldMapping '\x0216' = CM '\x0217' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH COMMA BELOW +foldMapping '\x0218' = CM '\x0219' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH COMMA BELOW +foldMapping '\x021A' = CM '\x021B' '\0' '\0' +-- LATIN CAPITAL LETTER YOGH +foldMapping '\x021C' = CM '\x021D' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH CARON +foldMapping '\x021E' = CM '\x021F' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH LONG RIGHT LEG +foldMapping '\x0220' = CM '\x019E' '\0' '\0' +-- LATIN CAPITAL LETTER OU +foldMapping '\x0222' = CM '\x0223' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH HOOK +foldMapping '\x0224' = CM '\x0225' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH DOT ABOVE +foldMapping '\x0226' = CM '\x0227' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CEDILLA +foldMapping '\x0228' = CM '\x0229' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON +foldMapping '\x022A' = CM '\x022B' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH TILDE AND MACRON +foldMapping '\x022C' = CM '\x022D' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH DOT ABOVE +foldMapping '\x022E' = CM '\x022F' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON +foldMapping '\x0230' = CM '\x0231' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH MACRON +foldMapping '\x0232' = CM '\x0233' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH STROKE +foldMapping '\x023A' = CM '\x2C65' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH STROKE +foldMapping '\x023B' = CM '\x023C' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH BAR +foldMapping '\x023D' = CM '\x019A' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH DIAGONAL STROKE +foldMapping '\x023E' = CM '\x2C66' '\0' '\0' +-- LATIN CAPITAL LETTER GLOTTAL STOP +foldMapping '\x0241' = CM '\x0242' '\0' '\0' +-- LATIN CAPITAL LETTER B WITH STROKE +foldMapping '\x0243' = CM '\x0180' '\0' '\0' +-- LATIN CAPITAL LETTER U BAR +foldMapping '\x0244' = CM '\x0289' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED V +foldMapping '\x0245' = CM '\x028C' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH STROKE +foldMapping '\x0246' = CM '\x0247' '\0' '\0' +-- LATIN CAPITAL LETTER J WITH STROKE +foldMapping '\x0248' = CM '\x0249' '\0' '\0' +-- LATIN CAPITAL LETTER SMALL Q WITH HOOK TAIL +foldMapping '\x024A' = CM '\x024B' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH STROKE +foldMapping '\x024C' = CM '\x024D' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH STROKE +foldMapping '\x024E' = CM '\x024F' '\0' '\0' +-- COMBINING GREEK YPOGEGRAMMENI +foldMapping '\x0345' = CM '\x03B9' '\0' '\0' +-- GREEK CAPITAL LETTER HETA +foldMapping '\x0370' = CM '\x0371' '\0' '\0' +-- GREEK CAPITAL LETTER ARCHAIC SAMPI +foldMapping '\x0372' = CM '\x0373' '\0' '\0' +-- GREEK CAPITAL LETTER PAMPHYLIAN DIGAMMA +foldMapping '\x0376' = CM '\x0377' '\0' '\0' +-- GREEK CAPITAL LETTER YOT +foldMapping '\x037F' = CM '\x03F3' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH TONOS +foldMapping '\x0386' = CM '\x03AC' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON WITH TONOS +foldMapping '\x0388' = CM '\x03AD' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH TONOS +foldMapping '\x0389' = CM '\x03AE' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH TONOS +foldMapping '\x038A' = CM '\x03AF' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON WITH TONOS +foldMapping '\x038C' = CM '\x03CC' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON WITH TONOS +foldMapping '\x038E' = CM '\x03CD' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH TONOS +foldMapping '\x038F' = CM '\x03CE' '\0' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS +foldMapping '\x0390' = CM '\x03B9' '\x0308' '\x0301' +-- GREEK CAPITAL LETTER ALPHA +foldMapping '\x0391' = CM '\x03B1' '\0' '\0' +-- GREEK CAPITAL LETTER BETA +foldMapping '\x0392' = CM '\x03B2' '\0' '\0' +-- GREEK CAPITAL LETTER GAMMA +foldMapping '\x0393' = CM '\x03B3' '\0' '\0' +-- GREEK CAPITAL LETTER DELTA +foldMapping '\x0394' = CM '\x03B4' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON +foldMapping '\x0395' = CM '\x03B5' '\0' '\0' +-- GREEK CAPITAL LETTER ZETA +foldMapping '\x0396' = CM '\x03B6' '\0' '\0' +-- GREEK CAPITAL LETTER ETA +foldMapping '\x0397' = CM '\x03B7' '\0' '\0' +-- GREEK CAPITAL LETTER THETA +foldMapping '\x0398' = CM '\x03B8' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA +foldMapping '\x0399' = CM '\x03B9' '\0' '\0' +-- GREEK CAPITAL LETTER KAPPA +foldMapping '\x039A' = CM '\x03BA' '\0' '\0' +-- GREEK CAPITAL LETTER LAMDA +foldMapping '\x039B' = CM '\x03BB' '\0' '\0' +-- GREEK CAPITAL LETTER MU +foldMapping '\x039C' = CM '\x03BC' '\0' '\0' +-- GREEK CAPITAL LETTER NU +foldMapping '\x039D' = CM '\x03BD' '\0' '\0' +-- GREEK CAPITAL LETTER XI +foldMapping '\x039E' = CM '\x03BE' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON +foldMapping '\x039F' = CM '\x03BF' '\0' '\0' +-- GREEK CAPITAL LETTER PI +foldMapping '\x03A0' = CM '\x03C0' '\0' '\0' +-- GREEK CAPITAL LETTER RHO +foldMapping '\x03A1' = CM '\x03C1' '\0' '\0' +-- GREEK CAPITAL LETTER SIGMA +foldMapping '\x03A3' = CM '\x03C3' '\0' '\0' +-- GREEK CAPITAL LETTER TAU +foldMapping '\x03A4' = CM '\x03C4' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON +foldMapping '\x03A5' = CM '\x03C5' '\0' '\0' +-- GREEK CAPITAL LETTER PHI +foldMapping '\x03A6' = CM '\x03C6' '\0' '\0' +-- GREEK CAPITAL LETTER CHI +foldMapping '\x03A7' = CM '\x03C7' '\0' '\0' +-- GREEK CAPITAL LETTER PSI +foldMapping '\x03A8' = CM '\x03C8' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA +foldMapping '\x03A9' = CM '\x03C9' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH DIALYTIKA +foldMapping '\x03AA' = CM '\x03CA' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA +foldMapping '\x03AB' = CM '\x03CB' '\0' '\0' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS +foldMapping '\x03B0' = CM '\x03C5' '\x0308' '\x0301' +-- GREEK SMALL LETTER FINAL SIGMA +foldMapping '\x03C2' = CM '\x03C3' '\0' '\0' +-- GREEK CAPITAL KAI SYMBOL +foldMapping '\x03CF' = CM '\x03D7' '\0' '\0' +-- GREEK BETA SYMBOL +foldMapping '\x03D0' = CM '\x03B2' '\0' '\0' +-- GREEK THETA SYMBOL +foldMapping '\x03D1' = CM '\x03B8' '\0' '\0' +-- GREEK PHI SYMBOL +foldMapping '\x03D5' = CM '\x03C6' '\0' '\0' +-- GREEK PI SYMBOL +foldMapping '\x03D6' = CM '\x03C0' '\0' '\0' +-- GREEK LETTER ARCHAIC KOPPA +foldMapping '\x03D8' = CM '\x03D9' '\0' '\0' +-- GREEK LETTER STIGMA +foldMapping '\x03DA' = CM '\x03DB' '\0' '\0' +-- GREEK LETTER DIGAMMA +foldMapping '\x03DC' = CM '\x03DD' '\0' '\0' +-- GREEK LETTER KOPPA +foldMapping '\x03DE' = CM '\x03DF' '\0' '\0' +-- GREEK LETTER SAMPI +foldMapping '\x03E0' = CM '\x03E1' '\0' '\0' +-- COPTIC CAPITAL LETTER SHEI +foldMapping '\x03E2' = CM '\x03E3' '\0' '\0' +-- COPTIC CAPITAL LETTER FEI +foldMapping '\x03E4' = CM '\x03E5' '\0' '\0' +-- COPTIC CAPITAL LETTER KHEI +foldMapping '\x03E6' = CM '\x03E7' '\0' '\0' +-- COPTIC CAPITAL LETTER HORI +foldMapping '\x03E8' = CM '\x03E9' '\0' '\0' +-- COPTIC CAPITAL LETTER GANGIA +foldMapping '\x03EA' = CM '\x03EB' '\0' '\0' +-- COPTIC CAPITAL LETTER SHIMA +foldMapping '\x03EC' = CM '\x03ED' '\0' '\0' +-- COPTIC CAPITAL LETTER DEI +foldMapping '\x03EE' = CM '\x03EF' '\0' '\0' +-- GREEK KAPPA SYMBOL +foldMapping '\x03F0' = CM '\x03BA' '\0' '\0' +-- GREEK RHO SYMBOL +foldMapping '\x03F1' = CM '\x03C1' '\0' '\0' +-- GREEK CAPITAL THETA SYMBOL +foldMapping '\x03F4' = CM '\x03B8' '\0' '\0' +-- GREEK LUNATE EPSILON SYMBOL +foldMapping '\x03F5' = CM '\x03B5' '\0' '\0' +-- GREEK CAPITAL LETTER SHO +foldMapping '\x03F7' = CM '\x03F8' '\0' '\0' +-- GREEK CAPITAL LUNATE SIGMA SYMBOL +foldMapping '\x03F9' = CM '\x03F2' '\0' '\0' +-- GREEK CAPITAL LETTER SAN +foldMapping '\x03FA' = CM '\x03FB' '\0' '\0' +-- GREEK CAPITAL REVERSED LUNATE SIGMA SYMBOL +foldMapping '\x03FD' = CM '\x037B' '\0' '\0' +-- GREEK CAPITAL DOTTED LUNATE SIGMA SYMBOL +foldMapping '\x03FE' = CM '\x037C' '\0' '\0' +-- GREEK CAPITAL REVERSED DOTTED LUNATE SIGMA SYMBOL +foldMapping '\x03FF' = CM '\x037D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IE WITH GRAVE +foldMapping '\x0400' = CM '\x0450' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IO +foldMapping '\x0401' = CM '\x0451' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DJE +foldMapping '\x0402' = CM '\x0452' '\0' '\0' +-- CYRILLIC CAPITAL LETTER GJE +foldMapping '\x0403' = CM '\x0453' '\0' '\0' +-- CYRILLIC CAPITAL LETTER UKRAINIAN IE +foldMapping '\x0404' = CM '\x0454' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DZE +foldMapping '\x0405' = CM '\x0455' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BYELORUSSIAN-UKRAINIAN I +foldMapping '\x0406' = CM '\x0456' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YI +foldMapping '\x0407' = CM '\x0457' '\0' '\0' +-- CYRILLIC CAPITAL LETTER JE +foldMapping '\x0408' = CM '\x0458' '\0' '\0' +-- CYRILLIC CAPITAL LETTER LJE +foldMapping '\x0409' = CM '\x0459' '\0' '\0' +-- CYRILLIC CAPITAL LETTER NJE +foldMapping '\x040A' = CM '\x045A' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TSHE +foldMapping '\x040B' = CM '\x045B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KJE +foldMapping '\x040C' = CM '\x045C' '\0' '\0' +-- CYRILLIC CAPITAL LETTER I WITH GRAVE +foldMapping '\x040D' = CM '\x045D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SHORT U +foldMapping '\x040E' = CM '\x045E' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DZHE +foldMapping '\x040F' = CM '\x045F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER A +foldMapping '\x0410' = CM '\x0430' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BE +foldMapping '\x0411' = CM '\x0431' '\0' '\0' +-- CYRILLIC CAPITAL LETTER VE +foldMapping '\x0412' = CM '\x0432' '\0' '\0' +-- CYRILLIC CAPITAL LETTER GHE +foldMapping '\x0413' = CM '\x0433' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DE +foldMapping '\x0414' = CM '\x0434' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IE +foldMapping '\x0415' = CM '\x0435' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZHE +foldMapping '\x0416' = CM '\x0436' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZE +foldMapping '\x0417' = CM '\x0437' '\0' '\0' +-- CYRILLIC CAPITAL LETTER I +foldMapping '\x0418' = CM '\x0438' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SHORT I +foldMapping '\x0419' = CM '\x0439' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KA +foldMapping '\x041A' = CM '\x043A' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EL +foldMapping '\x041B' = CM '\x043B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EM +foldMapping '\x041C' = CM '\x043C' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EN +foldMapping '\x041D' = CM '\x043D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER O +foldMapping '\x041E' = CM '\x043E' '\0' '\0' +-- CYRILLIC CAPITAL LETTER PE +foldMapping '\x041F' = CM '\x043F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ER +foldMapping '\x0420' = CM '\x0440' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ES +foldMapping '\x0421' = CM '\x0441' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TE +foldMapping '\x0422' = CM '\x0442' '\0' '\0' +-- CYRILLIC CAPITAL LETTER U +foldMapping '\x0423' = CM '\x0443' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EF +foldMapping '\x0424' = CM '\x0444' '\0' '\0' +-- CYRILLIC CAPITAL LETTER HA +foldMapping '\x0425' = CM '\x0445' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TSE +foldMapping '\x0426' = CM '\x0446' '\0' '\0' +-- CYRILLIC CAPITAL LETTER CHE +foldMapping '\x0427' = CM '\x0447' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SHA +foldMapping '\x0428' = CM '\x0448' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SHCHA +foldMapping '\x0429' = CM '\x0449' '\0' '\0' +-- CYRILLIC CAPITAL LETTER HARD SIGN +foldMapping '\x042A' = CM '\x044A' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YERU +foldMapping '\x042B' = CM '\x044B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SOFT SIGN +foldMapping '\x042C' = CM '\x044C' '\0' '\0' +-- CYRILLIC CAPITAL LETTER E +foldMapping '\x042D' = CM '\x044D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YU +foldMapping '\x042E' = CM '\x044E' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YA +foldMapping '\x042F' = CM '\x044F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER OMEGA +foldMapping '\x0460' = CM '\x0461' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YAT +foldMapping '\x0462' = CM '\x0463' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IOTIFIED E +foldMapping '\x0464' = CM '\x0465' '\0' '\0' +-- CYRILLIC CAPITAL LETTER LITTLE YUS +foldMapping '\x0466' = CM '\x0467' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS +foldMapping '\x0468' = CM '\x0469' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BIG YUS +foldMapping '\x046A' = CM '\x046B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS +foldMapping '\x046C' = CM '\x046D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KSI +foldMapping '\x046E' = CM '\x046F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER PSI +foldMapping '\x0470' = CM '\x0471' '\0' '\0' +-- CYRILLIC CAPITAL LETTER FITA +foldMapping '\x0472' = CM '\x0473' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IZHITSA +foldMapping '\x0474' = CM '\x0475' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT +foldMapping '\x0476' = CM '\x0477' '\0' '\0' +-- CYRILLIC CAPITAL LETTER UK +foldMapping '\x0478' = CM '\x0479' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ROUND OMEGA +foldMapping '\x047A' = CM '\x047B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER OMEGA WITH TITLO +foldMapping '\x047C' = CM '\x047D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER OT +foldMapping '\x047E' = CM '\x047F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOPPA +foldMapping '\x0480' = CM '\x0481' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SHORT I WITH TAIL +foldMapping '\x048A' = CM '\x048B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SEMISOFT SIGN +foldMapping '\x048C' = CM '\x048D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ER WITH TICK +foldMapping '\x048E' = CM '\x048F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER GHE WITH UPTURN +foldMapping '\x0490' = CM '\x0491' '\0' '\0' +-- CYRILLIC CAPITAL LETTER GHE WITH STROKE +foldMapping '\x0492' = CM '\x0493' '\0' '\0' +-- CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK +foldMapping '\x0494' = CM '\x0495' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER +foldMapping '\x0496' = CM '\x0497' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZE WITH DESCENDER +foldMapping '\x0498' = CM '\x0499' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KA WITH DESCENDER +foldMapping '\x049A' = CM '\x049B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE +foldMapping '\x049C' = CM '\x049D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KA WITH STROKE +foldMapping '\x049E' = CM '\x049F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BASHKIR KA +foldMapping '\x04A0' = CM '\x04A1' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EN WITH DESCENDER +foldMapping '\x04A2' = CM '\x04A3' '\0' '\0' +-- CYRILLIC CAPITAL LIGATURE EN GHE +foldMapping '\x04A4' = CM '\x04A5' '\0' '\0' +-- CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK +foldMapping '\x04A6' = CM '\x04A7' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ABKHASIAN HA +foldMapping '\x04A8' = CM '\x04A9' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ES WITH DESCENDER +foldMapping '\x04AA' = CM '\x04AB' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TE WITH DESCENDER +foldMapping '\x04AC' = CM '\x04AD' '\0' '\0' +-- CYRILLIC CAPITAL LETTER STRAIGHT U +foldMapping '\x04AE' = CM '\x04AF' '\0' '\0' +-- CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE +foldMapping '\x04B0' = CM '\x04B1' '\0' '\0' +-- CYRILLIC CAPITAL LETTER HA WITH DESCENDER +foldMapping '\x04B2' = CM '\x04B3' '\0' '\0' +-- CYRILLIC CAPITAL LIGATURE TE TSE +foldMapping '\x04B4' = CM '\x04B5' '\0' '\0' +-- CYRILLIC CAPITAL LETTER CHE WITH DESCENDER +foldMapping '\x04B6' = CM '\x04B7' '\0' '\0' +-- CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE +foldMapping '\x04B8' = CM '\x04B9' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SHHA +foldMapping '\x04BA' = CM '\x04BB' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ABKHASIAN CHE +foldMapping '\x04BC' = CM '\x04BD' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER +foldMapping '\x04BE' = CM '\x04BF' '\0' '\0' +-- CYRILLIC LETTER PALOCHKA +foldMapping '\x04C0' = CM '\x04CF' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZHE WITH BREVE +foldMapping '\x04C1' = CM '\x04C2' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KA WITH HOOK +foldMapping '\x04C3' = CM '\x04C4' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EL WITH TAIL +foldMapping '\x04C5' = CM '\x04C6' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EN WITH HOOK +foldMapping '\x04C7' = CM '\x04C8' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EN WITH TAIL +foldMapping '\x04C9' = CM '\x04CA' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KHAKASSIAN CHE +foldMapping '\x04CB' = CM '\x04CC' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EM WITH TAIL +foldMapping '\x04CD' = CM '\x04CE' '\0' '\0' +-- CYRILLIC CAPITAL LETTER A WITH BREVE +foldMapping '\x04D0' = CM '\x04D1' '\0' '\0' +-- CYRILLIC CAPITAL LETTER A WITH DIAERESIS +foldMapping '\x04D2' = CM '\x04D3' '\0' '\0' +-- CYRILLIC CAPITAL LIGATURE A IE +foldMapping '\x04D4' = CM '\x04D5' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IE WITH BREVE +foldMapping '\x04D6' = CM '\x04D7' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SCHWA +foldMapping '\x04D8' = CM '\x04D9' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS +foldMapping '\x04DA' = CM '\x04DB' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS +foldMapping '\x04DC' = CM '\x04DD' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS +foldMapping '\x04DE' = CM '\x04DF' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ABKHASIAN DZE +foldMapping '\x04E0' = CM '\x04E1' '\0' '\0' +-- CYRILLIC CAPITAL LETTER I WITH MACRON +foldMapping '\x04E2' = CM '\x04E3' '\0' '\0' +-- CYRILLIC CAPITAL LETTER I WITH DIAERESIS +foldMapping '\x04E4' = CM '\x04E5' '\0' '\0' +-- CYRILLIC CAPITAL LETTER O WITH DIAERESIS +foldMapping '\x04E6' = CM '\x04E7' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BARRED O +foldMapping '\x04E8' = CM '\x04E9' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS +foldMapping '\x04EA' = CM '\x04EB' '\0' '\0' +-- CYRILLIC CAPITAL LETTER E WITH DIAERESIS +foldMapping '\x04EC' = CM '\x04ED' '\0' '\0' +-- CYRILLIC CAPITAL LETTER U WITH MACRON +foldMapping '\x04EE' = CM '\x04EF' '\0' '\0' +-- CYRILLIC CAPITAL LETTER U WITH DIAERESIS +foldMapping '\x04F0' = CM '\x04F1' '\0' '\0' +-- CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE +foldMapping '\x04F2' = CM '\x04F3' '\0' '\0' +-- CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS +foldMapping '\x04F4' = CM '\x04F5' '\0' '\0' +-- CYRILLIC CAPITAL LETTER GHE WITH DESCENDER +foldMapping '\x04F6' = CM '\x04F7' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS +foldMapping '\x04F8' = CM '\x04F9' '\0' '\0' +-- CYRILLIC CAPITAL LETTER GHE WITH STROKE AND HOOK +foldMapping '\x04FA' = CM '\x04FB' '\0' '\0' +-- CYRILLIC CAPITAL LETTER HA WITH HOOK +foldMapping '\x04FC' = CM '\x04FD' '\0' '\0' +-- CYRILLIC CAPITAL LETTER HA WITH STROKE +foldMapping '\x04FE' = CM '\x04FF' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOMI DE +foldMapping '\x0500' = CM '\x0501' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOMI DJE +foldMapping '\x0502' = CM '\x0503' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOMI ZJE +foldMapping '\x0504' = CM '\x0505' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOMI DZJE +foldMapping '\x0506' = CM '\x0507' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOMI LJE +foldMapping '\x0508' = CM '\x0509' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOMI NJE +foldMapping '\x050A' = CM '\x050B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOMI SJE +foldMapping '\x050C' = CM '\x050D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOMI TJE +foldMapping '\x050E' = CM '\x050F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER REVERSED ZE +foldMapping '\x0510' = CM '\x0511' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EL WITH HOOK +foldMapping '\x0512' = CM '\x0513' '\0' '\0' +-- CYRILLIC CAPITAL LETTER LHA +foldMapping '\x0514' = CM '\x0515' '\0' '\0' +-- CYRILLIC CAPITAL LETTER RHA +foldMapping '\x0516' = CM '\x0517' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YAE +foldMapping '\x0518' = CM '\x0519' '\0' '\0' +-- CYRILLIC CAPITAL LETTER QA +foldMapping '\x051A' = CM '\x051B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER WE +foldMapping '\x051C' = CM '\x051D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ALEUT KA +foldMapping '\x051E' = CM '\x051F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EL WITH MIDDLE HOOK +foldMapping '\x0520' = CM '\x0521' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EN WITH MIDDLE HOOK +foldMapping '\x0522' = CM '\x0523' '\0' '\0' +-- CYRILLIC CAPITAL LETTER PE WITH DESCENDER +foldMapping '\x0524' = CM '\x0525' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SHHA WITH DESCENDER +foldMapping '\x0526' = CM '\x0527' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EN WITH LEFT HOOK +foldMapping '\x0528' = CM '\x0529' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DZZHE +foldMapping '\x052A' = CM '\x052B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DCHE +foldMapping '\x052C' = CM '\x052D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EL WITH DESCENDER +foldMapping '\x052E' = CM '\x052F' '\0' '\0' +-- ARMENIAN CAPITAL LETTER AYB +foldMapping '\x0531' = CM '\x0561' '\0' '\0' +-- ARMENIAN CAPITAL LETTER BEN +foldMapping '\x0532' = CM '\x0562' '\0' '\0' +-- ARMENIAN CAPITAL LETTER GIM +foldMapping '\x0533' = CM '\x0563' '\0' '\0' +-- ARMENIAN CAPITAL LETTER DA +foldMapping '\x0534' = CM '\x0564' '\0' '\0' +-- ARMENIAN CAPITAL LETTER ECH +foldMapping '\x0535' = CM '\x0565' '\0' '\0' +-- ARMENIAN CAPITAL LETTER ZA +foldMapping '\x0536' = CM '\x0566' '\0' '\0' +-- ARMENIAN CAPITAL LETTER EH +foldMapping '\x0537' = CM '\x0567' '\0' '\0' +-- ARMENIAN CAPITAL LETTER ET +foldMapping '\x0538' = CM '\x0568' '\0' '\0' +-- ARMENIAN CAPITAL LETTER TO +foldMapping '\x0539' = CM '\x0569' '\0' '\0' +-- ARMENIAN CAPITAL LETTER ZHE +foldMapping '\x053A' = CM '\x056A' '\0' '\0' +-- ARMENIAN CAPITAL LETTER INI +foldMapping '\x053B' = CM '\x056B' '\0' '\0' +-- ARMENIAN CAPITAL LETTER LIWN +foldMapping '\x053C' = CM '\x056C' '\0' '\0' +-- ARMENIAN CAPITAL LETTER XEH +foldMapping '\x053D' = CM '\x056D' '\0' '\0' +-- ARMENIAN CAPITAL LETTER CA +foldMapping '\x053E' = CM '\x056E' '\0' '\0' +-- ARMENIAN CAPITAL LETTER KEN +foldMapping '\x053F' = CM '\x056F' '\0' '\0' +-- ARMENIAN CAPITAL LETTER HO +foldMapping '\x0540' = CM '\x0570' '\0' '\0' +-- ARMENIAN CAPITAL LETTER JA +foldMapping '\x0541' = CM '\x0571' '\0' '\0' +-- ARMENIAN CAPITAL LETTER GHAD +foldMapping '\x0542' = CM '\x0572' '\0' '\0' +-- ARMENIAN CAPITAL LETTER CHEH +foldMapping '\x0543' = CM '\x0573' '\0' '\0' +-- ARMENIAN CAPITAL LETTER MEN +foldMapping '\x0544' = CM '\x0574' '\0' '\0' +-- ARMENIAN CAPITAL LETTER YI +foldMapping '\x0545' = CM '\x0575' '\0' '\0' +-- ARMENIAN CAPITAL LETTER NOW +foldMapping '\x0546' = CM '\x0576' '\0' '\0' +-- ARMENIAN CAPITAL LETTER SHA +foldMapping '\x0547' = CM '\x0577' '\0' '\0' +-- ARMENIAN CAPITAL LETTER VO +foldMapping '\x0548' = CM '\x0578' '\0' '\0' +-- ARMENIAN CAPITAL LETTER CHA +foldMapping '\x0549' = CM '\x0579' '\0' '\0' +-- ARMENIAN CAPITAL LETTER PEH +foldMapping '\x054A' = CM '\x057A' '\0' '\0' +-- ARMENIAN CAPITAL LETTER JHEH +foldMapping '\x054B' = CM '\x057B' '\0' '\0' +-- ARMENIAN CAPITAL LETTER RA +foldMapping '\x054C' = CM '\x057C' '\0' '\0' +-- ARMENIAN CAPITAL LETTER SEH +foldMapping '\x054D' = CM '\x057D' '\0' '\0' +-- ARMENIAN CAPITAL LETTER VEW +foldMapping '\x054E' = CM '\x057E' '\0' '\0' +-- ARMENIAN CAPITAL LETTER TIWN +foldMapping '\x054F' = CM '\x057F' '\0' '\0' +-- ARMENIAN CAPITAL LETTER REH +foldMapping '\x0550' = CM '\x0580' '\0' '\0' +-- ARMENIAN CAPITAL LETTER CO +foldMapping '\x0551' = CM '\x0581' '\0' '\0' +-- ARMENIAN CAPITAL LETTER YIWN +foldMapping '\x0552' = CM '\x0582' '\0' '\0' +-- ARMENIAN CAPITAL LETTER PIWR +foldMapping '\x0553' = CM '\x0583' '\0' '\0' +-- ARMENIAN CAPITAL LETTER KEH +foldMapping '\x0554' = CM '\x0584' '\0' '\0' +-- ARMENIAN CAPITAL LETTER OH +foldMapping '\x0555' = CM '\x0585' '\0' '\0' +-- ARMENIAN CAPITAL LETTER FEH +foldMapping '\x0556' = CM '\x0586' '\0' '\0' +-- ARMENIAN SMALL LIGATURE ECH YIWN +foldMapping '\x0587' = CM '\x0565' '\x0582' '\0' +-- GEORGIAN CAPITAL LETTER AN +foldMapping '\x10A0' = CM '\x2D00' '\0' '\0' +-- GEORGIAN CAPITAL LETTER BAN +foldMapping '\x10A1' = CM '\x2D01' '\0' '\0' +-- GEORGIAN CAPITAL LETTER GAN +foldMapping '\x10A2' = CM '\x2D02' '\0' '\0' +-- GEORGIAN CAPITAL LETTER DON +foldMapping '\x10A3' = CM '\x2D03' '\0' '\0' +-- GEORGIAN CAPITAL LETTER EN +foldMapping '\x10A4' = CM '\x2D04' '\0' '\0' +-- GEORGIAN CAPITAL LETTER VIN +foldMapping '\x10A5' = CM '\x2D05' '\0' '\0' +-- GEORGIAN CAPITAL LETTER ZEN +foldMapping '\x10A6' = CM '\x2D06' '\0' '\0' +-- GEORGIAN CAPITAL LETTER TAN +foldMapping '\x10A7' = CM '\x2D07' '\0' '\0' +-- GEORGIAN CAPITAL LETTER IN +foldMapping '\x10A8' = CM '\x2D08' '\0' '\0' +-- GEORGIAN CAPITAL LETTER KAN +foldMapping '\x10A9' = CM '\x2D09' '\0' '\0' +-- GEORGIAN CAPITAL LETTER LAS +foldMapping '\x10AA' = CM '\x2D0A' '\0' '\0' +-- GEORGIAN CAPITAL LETTER MAN +foldMapping '\x10AB' = CM '\x2D0B' '\0' '\0' +-- GEORGIAN CAPITAL LETTER NAR +foldMapping '\x10AC' = CM '\x2D0C' '\0' '\0' +-- GEORGIAN CAPITAL LETTER ON +foldMapping '\x10AD' = CM '\x2D0D' '\0' '\0' +-- GEORGIAN CAPITAL LETTER PAR +foldMapping '\x10AE' = CM '\x2D0E' '\0' '\0' +-- GEORGIAN CAPITAL LETTER ZHAR +foldMapping '\x10AF' = CM '\x2D0F' '\0' '\0' +-- GEORGIAN CAPITAL LETTER RAE +foldMapping '\x10B0' = CM '\x2D10' '\0' '\0' +-- GEORGIAN CAPITAL LETTER SAN +foldMapping '\x10B1' = CM '\x2D11' '\0' '\0' +-- GEORGIAN CAPITAL LETTER TAR +foldMapping '\x10B2' = CM '\x2D12' '\0' '\0' +-- GEORGIAN CAPITAL LETTER UN +foldMapping '\x10B3' = CM '\x2D13' '\0' '\0' +-- GEORGIAN CAPITAL LETTER PHAR +foldMapping '\x10B4' = CM '\x2D14' '\0' '\0' +-- GEORGIAN CAPITAL LETTER KHAR +foldMapping '\x10B5' = CM '\x2D15' '\0' '\0' +-- GEORGIAN CAPITAL LETTER GHAN +foldMapping '\x10B6' = CM '\x2D16' '\0' '\0' +-- GEORGIAN CAPITAL LETTER QAR +foldMapping '\x10B7' = CM '\x2D17' '\0' '\0' +-- GEORGIAN CAPITAL LETTER SHIN +foldMapping '\x10B8' = CM '\x2D18' '\0' '\0' +-- GEORGIAN CAPITAL LETTER CHIN +foldMapping '\x10B9' = CM '\x2D19' '\0' '\0' +-- GEORGIAN CAPITAL LETTER CAN +foldMapping '\x10BA' = CM '\x2D1A' '\0' '\0' +-- GEORGIAN CAPITAL LETTER JIL +foldMapping '\x10BB' = CM '\x2D1B' '\0' '\0' +-- GEORGIAN CAPITAL LETTER CIL +foldMapping '\x10BC' = CM '\x2D1C' '\0' '\0' +-- GEORGIAN CAPITAL LETTER CHAR +foldMapping '\x10BD' = CM '\x2D1D' '\0' '\0' +-- GEORGIAN CAPITAL LETTER XAN +foldMapping '\x10BE' = CM '\x2D1E' '\0' '\0' +-- GEORGIAN CAPITAL LETTER JHAN +foldMapping '\x10BF' = CM '\x2D1F' '\0' '\0' +-- GEORGIAN CAPITAL LETTER HAE +foldMapping '\x10C0' = CM '\x2D20' '\0' '\0' +-- GEORGIAN CAPITAL LETTER HE +foldMapping '\x10C1' = CM '\x2D21' '\0' '\0' +-- GEORGIAN CAPITAL LETTER HIE +foldMapping '\x10C2' = CM '\x2D22' '\0' '\0' +-- GEORGIAN CAPITAL LETTER WE +foldMapping '\x10C3' = CM '\x2D23' '\0' '\0' +-- GEORGIAN CAPITAL LETTER HAR +foldMapping '\x10C4' = CM '\x2D24' '\0' '\0' +-- GEORGIAN CAPITAL LETTER HOE +foldMapping '\x10C5' = CM '\x2D25' '\0' '\0' +-- GEORGIAN CAPITAL LETTER YN +foldMapping '\x10C7' = CM '\x2D27' '\0' '\0' +-- GEORGIAN CAPITAL LETTER AEN +foldMapping '\x10CD' = CM '\x2D2D' '\0' '\0' +-- CHEROKEE SMALL LETTER YE +foldMapping '\x13F8' = CM '\x13F0' '\0' '\0' +-- CHEROKEE SMALL LETTER YI +foldMapping '\x13F9' = CM '\x13F1' '\0' '\0' +-- CHEROKEE SMALL LETTER YO +foldMapping '\x13FA' = CM '\x13F2' '\0' '\0' +-- CHEROKEE SMALL LETTER YU +foldMapping '\x13FB' = CM '\x13F3' '\0' '\0' +-- CHEROKEE SMALL LETTER YV +foldMapping '\x13FC' = CM '\x13F4' '\0' '\0' +-- CHEROKEE SMALL LETTER MV +foldMapping '\x13FD' = CM '\x13F5' '\0' '\0' +-- CYRILLIC SMALL LETTER ROUNDED VE +foldMapping '\x1C80' = CM '\x0432' '\0' '\0' +-- CYRILLIC SMALL LETTER LONG-LEGGED DE +foldMapping '\x1C81' = CM '\x0434' '\0' '\0' +-- CYRILLIC SMALL LETTER NARROW O +foldMapping '\x1C82' = CM '\x043E' '\0' '\0' +-- CYRILLIC SMALL LETTER WIDE ES +foldMapping '\x1C83' = CM '\x0441' '\0' '\0' +-- CYRILLIC SMALL LETTER TALL TE +foldMapping '\x1C84' = CM '\x0442' '\0' '\0' +-- CYRILLIC SMALL LETTER THREE-LEGGED TE +foldMapping '\x1C85' = CM '\x0442' '\0' '\0' +-- CYRILLIC SMALL LETTER TALL HARD SIGN +foldMapping '\x1C86' = CM '\x044A' '\0' '\0' +-- CYRILLIC SMALL LETTER TALL YAT +foldMapping '\x1C87' = CM '\x0463' '\0' '\0' +-- CYRILLIC SMALL LETTER UNBLENDED UK +foldMapping '\x1C88' = CM '\xA64B' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH RING BELOW +foldMapping '\x1E00' = CM '\x1E01' '\0' '\0' +-- LATIN CAPITAL LETTER B WITH DOT ABOVE +foldMapping '\x1E02' = CM '\x1E03' '\0' '\0' +-- LATIN CAPITAL LETTER B WITH DOT BELOW +foldMapping '\x1E04' = CM '\x1E05' '\0' '\0' +-- LATIN CAPITAL LETTER B WITH LINE BELOW +foldMapping '\x1E06' = CM '\x1E07' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE +foldMapping '\x1E08' = CM '\x1E09' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH DOT ABOVE +foldMapping '\x1E0A' = CM '\x1E0B' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH DOT BELOW +foldMapping '\x1E0C' = CM '\x1E0D' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH LINE BELOW +foldMapping '\x1E0E' = CM '\x1E0F' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH CEDILLA +foldMapping '\x1E10' = CM '\x1E11' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW +foldMapping '\x1E12' = CM '\x1E13' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH MACRON AND GRAVE +foldMapping '\x1E14' = CM '\x1E15' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH MACRON AND ACUTE +foldMapping '\x1E16' = CM '\x1E17' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW +foldMapping '\x1E18' = CM '\x1E19' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH TILDE BELOW +foldMapping '\x1E1A' = CM '\x1E1B' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE +foldMapping '\x1E1C' = CM '\x1E1D' '\0' '\0' +-- LATIN CAPITAL LETTER F WITH DOT ABOVE +foldMapping '\x1E1E' = CM '\x1E1F' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH MACRON +foldMapping '\x1E20' = CM '\x1E21' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH DOT ABOVE +foldMapping '\x1E22' = CM '\x1E23' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH DOT BELOW +foldMapping '\x1E24' = CM '\x1E25' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH DIAERESIS +foldMapping '\x1E26' = CM '\x1E27' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH CEDILLA +foldMapping '\x1E28' = CM '\x1E29' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH BREVE BELOW +foldMapping '\x1E2A' = CM '\x1E2B' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH TILDE BELOW +foldMapping '\x1E2C' = CM '\x1E2D' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE +foldMapping '\x1E2E' = CM '\x1E2F' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH ACUTE +foldMapping '\x1E30' = CM '\x1E31' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH DOT BELOW +foldMapping '\x1E32' = CM '\x1E33' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH LINE BELOW +foldMapping '\x1E34' = CM '\x1E35' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH DOT BELOW +foldMapping '\x1E36' = CM '\x1E37' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON +foldMapping '\x1E38' = CM '\x1E39' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH LINE BELOW +foldMapping '\x1E3A' = CM '\x1E3B' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW +foldMapping '\x1E3C' = CM '\x1E3D' '\0' '\0' +-- LATIN CAPITAL LETTER M WITH ACUTE +foldMapping '\x1E3E' = CM '\x1E3F' '\0' '\0' +-- LATIN CAPITAL LETTER M WITH DOT ABOVE +foldMapping '\x1E40' = CM '\x1E41' '\0' '\0' +-- LATIN CAPITAL LETTER M WITH DOT BELOW +foldMapping '\x1E42' = CM '\x1E43' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH DOT ABOVE +foldMapping '\x1E44' = CM '\x1E45' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH DOT BELOW +foldMapping '\x1E46' = CM '\x1E47' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH LINE BELOW +foldMapping '\x1E48' = CM '\x1E49' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW +foldMapping '\x1E4A' = CM '\x1E4B' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH TILDE AND ACUTE +foldMapping '\x1E4C' = CM '\x1E4D' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS +foldMapping '\x1E4E' = CM '\x1E4F' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH MACRON AND GRAVE +foldMapping '\x1E50' = CM '\x1E51' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH MACRON AND ACUTE +foldMapping '\x1E52' = CM '\x1E53' '\0' '\0' +-- LATIN CAPITAL LETTER P WITH ACUTE +foldMapping '\x1E54' = CM '\x1E55' '\0' '\0' +-- LATIN CAPITAL LETTER P WITH DOT ABOVE +foldMapping '\x1E56' = CM '\x1E57' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH DOT ABOVE +foldMapping '\x1E58' = CM '\x1E59' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH DOT BELOW +foldMapping '\x1E5A' = CM '\x1E5B' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON +foldMapping '\x1E5C' = CM '\x1E5D' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH LINE BELOW +foldMapping '\x1E5E' = CM '\x1E5F' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH DOT ABOVE +foldMapping '\x1E60' = CM '\x1E61' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH DOT BELOW +foldMapping '\x1E62' = CM '\x1E63' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE +foldMapping '\x1E64' = CM '\x1E65' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE +foldMapping '\x1E66' = CM '\x1E67' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE +foldMapping '\x1E68' = CM '\x1E69' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH DOT ABOVE +foldMapping '\x1E6A' = CM '\x1E6B' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH DOT BELOW +foldMapping '\x1E6C' = CM '\x1E6D' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH LINE BELOW +foldMapping '\x1E6E' = CM '\x1E6F' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW +foldMapping '\x1E70' = CM '\x1E71' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DIAERESIS BELOW +foldMapping '\x1E72' = CM '\x1E73' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH TILDE BELOW +foldMapping '\x1E74' = CM '\x1E75' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW +foldMapping '\x1E76' = CM '\x1E77' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH TILDE AND ACUTE +foldMapping '\x1E78' = CM '\x1E79' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS +foldMapping '\x1E7A' = CM '\x1E7B' '\0' '\0' +-- LATIN CAPITAL LETTER V WITH TILDE +foldMapping '\x1E7C' = CM '\x1E7D' '\0' '\0' +-- LATIN CAPITAL LETTER V WITH DOT BELOW +foldMapping '\x1E7E' = CM '\x1E7F' '\0' '\0' +-- LATIN CAPITAL LETTER W WITH GRAVE +foldMapping '\x1E80' = CM '\x1E81' '\0' '\0' +-- LATIN CAPITAL LETTER W WITH ACUTE +foldMapping '\x1E82' = CM '\x1E83' '\0' '\0' +-- LATIN CAPITAL LETTER W WITH DIAERESIS +foldMapping '\x1E84' = CM '\x1E85' '\0' '\0' +-- LATIN CAPITAL LETTER W WITH DOT ABOVE +foldMapping '\x1E86' = CM '\x1E87' '\0' '\0' +-- LATIN CAPITAL LETTER W WITH DOT BELOW +foldMapping '\x1E88' = CM '\x1E89' '\0' '\0' +-- LATIN CAPITAL LETTER X WITH DOT ABOVE +foldMapping '\x1E8A' = CM '\x1E8B' '\0' '\0' +-- LATIN CAPITAL LETTER X WITH DIAERESIS +foldMapping '\x1E8C' = CM '\x1E8D' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH DOT ABOVE +foldMapping '\x1E8E' = CM '\x1E8F' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH CIRCUMFLEX +foldMapping '\x1E90' = CM '\x1E91' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH DOT BELOW +foldMapping '\x1E92' = CM '\x1E93' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH LINE BELOW +foldMapping '\x1E94' = CM '\x1E95' '\0' '\0' +-- LATIN SMALL LETTER H WITH LINE BELOW +foldMapping '\x1E96' = CM '\x0068' '\x0331' '\0' +-- LATIN SMALL LETTER T WITH DIAERESIS +foldMapping '\x1E97' = CM '\x0074' '\x0308' '\0' +-- LATIN SMALL LETTER W WITH RING ABOVE +foldMapping '\x1E98' = CM '\x0077' '\x030A' '\0' +-- LATIN SMALL LETTER Y WITH RING ABOVE +foldMapping '\x1E99' = CM '\x0079' '\x030A' '\0' +-- LATIN SMALL LETTER A WITH RIGHT HALF RING +foldMapping '\x1E9A' = CM '\x0061' '\x02BE' '\0' +-- LATIN SMALL LETTER LONG S WITH DOT ABOVE +foldMapping '\x1E9B' = CM '\x1E61' '\0' '\0' +-- LATIN CAPITAL LETTER SHARP S +foldMapping '\x1E9E' = CM '\x0073' '\x0073' '\0' +-- LATIN CAPITAL LETTER A WITH DOT BELOW +foldMapping '\x1EA0' = CM '\x1EA1' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH HOOK ABOVE +foldMapping '\x1EA2' = CM '\x1EA3' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE +foldMapping '\x1EA4' = CM '\x1EA5' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE +foldMapping '\x1EA6' = CM '\x1EA7' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE +foldMapping '\x1EA8' = CM '\x1EA9' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE +foldMapping '\x1EAA' = CM '\x1EAB' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW +foldMapping '\x1EAC' = CM '\x1EAD' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH BREVE AND ACUTE +foldMapping '\x1EAE' = CM '\x1EAF' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH BREVE AND GRAVE +foldMapping '\x1EB0' = CM '\x1EB1' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE +foldMapping '\x1EB2' = CM '\x1EB3' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH BREVE AND TILDE +foldMapping '\x1EB4' = CM '\x1EB5' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW +foldMapping '\x1EB6' = CM '\x1EB7' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH DOT BELOW +foldMapping '\x1EB8' = CM '\x1EB9' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH HOOK ABOVE +foldMapping '\x1EBA' = CM '\x1EBB' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH TILDE +foldMapping '\x1EBC' = CM '\x1EBD' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE +foldMapping '\x1EBE' = CM '\x1EBF' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE +foldMapping '\x1EC0' = CM '\x1EC1' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE +foldMapping '\x1EC2' = CM '\x1EC3' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE +foldMapping '\x1EC4' = CM '\x1EC5' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW +foldMapping '\x1EC6' = CM '\x1EC7' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH HOOK ABOVE +foldMapping '\x1EC8' = CM '\x1EC9' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH DOT BELOW +foldMapping '\x1ECA' = CM '\x1ECB' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH DOT BELOW +foldMapping '\x1ECC' = CM '\x1ECD' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH HOOK ABOVE +foldMapping '\x1ECE' = CM '\x1ECF' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE +foldMapping '\x1ED0' = CM '\x1ED1' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE +foldMapping '\x1ED2' = CM '\x1ED3' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE +foldMapping '\x1ED4' = CM '\x1ED5' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE +foldMapping '\x1ED6' = CM '\x1ED7' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW +foldMapping '\x1ED8' = CM '\x1ED9' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH HORN AND ACUTE +foldMapping '\x1EDA' = CM '\x1EDB' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH HORN AND GRAVE +foldMapping '\x1EDC' = CM '\x1EDD' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE +foldMapping '\x1EDE' = CM '\x1EDF' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH HORN AND TILDE +foldMapping '\x1EE0' = CM '\x1EE1' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW +foldMapping '\x1EE2' = CM '\x1EE3' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DOT BELOW +foldMapping '\x1EE4' = CM '\x1EE5' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH HOOK ABOVE +foldMapping '\x1EE6' = CM '\x1EE7' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH HORN AND ACUTE +foldMapping '\x1EE8' = CM '\x1EE9' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH HORN AND GRAVE +foldMapping '\x1EEA' = CM '\x1EEB' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE +foldMapping '\x1EEC' = CM '\x1EED' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH HORN AND TILDE +foldMapping '\x1EEE' = CM '\x1EEF' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW +foldMapping '\x1EF0' = CM '\x1EF1' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH GRAVE +foldMapping '\x1EF2' = CM '\x1EF3' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH DOT BELOW +foldMapping '\x1EF4' = CM '\x1EF5' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH HOOK ABOVE +foldMapping '\x1EF6' = CM '\x1EF7' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH TILDE +foldMapping '\x1EF8' = CM '\x1EF9' '\0' '\0' +-- LATIN CAPITAL LETTER MIDDLE-WELSH LL +foldMapping '\x1EFA' = CM '\x1EFB' '\0' '\0' +-- LATIN CAPITAL LETTER MIDDLE-WELSH V +foldMapping '\x1EFC' = CM '\x1EFD' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH LOOP +foldMapping '\x1EFE' = CM '\x1EFF' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI +foldMapping '\x1F08' = CM '\x1F00' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA +foldMapping '\x1F09' = CM '\x1F01' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA +foldMapping '\x1F0A' = CM '\x1F02' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA +foldMapping '\x1F0B' = CM '\x1F03' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA +foldMapping '\x1F0C' = CM '\x1F04' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA +foldMapping '\x1F0D' = CM '\x1F05' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI +foldMapping '\x1F0E' = CM '\x1F06' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI +foldMapping '\x1F0F' = CM '\x1F07' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON WITH PSILI +foldMapping '\x1F18' = CM '\x1F10' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON WITH DASIA +foldMapping '\x1F19' = CM '\x1F11' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON WITH PSILI AND VARIA +foldMapping '\x1F1A' = CM '\x1F12' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON WITH DASIA AND VARIA +foldMapping '\x1F1B' = CM '\x1F13' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON WITH PSILI AND OXIA +foldMapping '\x1F1C' = CM '\x1F14' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA +foldMapping '\x1F1D' = CM '\x1F15' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI +foldMapping '\x1F28' = CM '\x1F20' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA +foldMapping '\x1F29' = CM '\x1F21' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA +foldMapping '\x1F2A' = CM '\x1F22' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA +foldMapping '\x1F2B' = CM '\x1F23' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA +foldMapping '\x1F2C' = CM '\x1F24' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA +foldMapping '\x1F2D' = CM '\x1F25' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI +foldMapping '\x1F2E' = CM '\x1F26' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI +foldMapping '\x1F2F' = CM '\x1F27' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH PSILI +foldMapping '\x1F38' = CM '\x1F30' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH DASIA +foldMapping '\x1F39' = CM '\x1F31' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH PSILI AND VARIA +foldMapping '\x1F3A' = CM '\x1F32' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH DASIA AND VARIA +foldMapping '\x1F3B' = CM '\x1F33' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH PSILI AND OXIA +foldMapping '\x1F3C' = CM '\x1F34' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH DASIA AND OXIA +foldMapping '\x1F3D' = CM '\x1F35' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH PSILI AND PERISPOMENI +foldMapping '\x1F3E' = CM '\x1F36' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH DASIA AND PERISPOMENI +foldMapping '\x1F3F' = CM '\x1F37' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON WITH PSILI +foldMapping '\x1F48' = CM '\x1F40' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON WITH DASIA +foldMapping '\x1F49' = CM '\x1F41' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON WITH PSILI AND VARIA +foldMapping '\x1F4A' = CM '\x1F42' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON WITH DASIA AND VARIA +foldMapping '\x1F4B' = CM '\x1F43' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON WITH PSILI AND OXIA +foldMapping '\x1F4C' = CM '\x1F44' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA +foldMapping '\x1F4D' = CM '\x1F45' '\0' '\0' +-- GREEK SMALL LETTER UPSILON WITH PSILI +foldMapping '\x1F50' = CM '\x03C5' '\x0313' '\0' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA +foldMapping '\x1F52' = CM '\x03C5' '\x0313' '\x0300' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA +foldMapping '\x1F54' = CM '\x03C5' '\x0313' '\x0301' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI +foldMapping '\x1F56' = CM '\x03C5' '\x0313' '\x0342' +-- GREEK CAPITAL LETTER UPSILON WITH DASIA +foldMapping '\x1F59' = CM '\x1F51' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA +foldMapping '\x1F5B' = CM '\x1F53' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA +foldMapping '\x1F5D' = CM '\x1F55' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI +foldMapping '\x1F5F' = CM '\x1F57' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI +foldMapping '\x1F68' = CM '\x1F60' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA +foldMapping '\x1F69' = CM '\x1F61' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA +foldMapping '\x1F6A' = CM '\x1F62' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA +foldMapping '\x1F6B' = CM '\x1F63' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA +foldMapping '\x1F6C' = CM '\x1F64' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA +foldMapping '\x1F6D' = CM '\x1F65' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI +foldMapping '\x1F6E' = CM '\x1F66' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI +foldMapping '\x1F6F' = CM '\x1F67' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI +foldMapping '\x1F80' = CM '\x1F00' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI +foldMapping '\x1F81' = CM '\x1F01' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1F82' = CM '\x1F02' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1F83' = CM '\x1F03' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1F84' = CM '\x1F04' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1F85' = CM '\x1F05' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1F86' = CM '\x1F06' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1F87' = CM '\x1F07' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI +foldMapping '\x1F88' = CM '\x1F00' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI +foldMapping '\x1F89' = CM '\x1F01' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1F8A' = CM '\x1F02' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1F8B' = CM '\x1F03' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1F8C' = CM '\x1F04' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1F8D' = CM '\x1F05' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1F8E' = CM '\x1F06' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1F8F' = CM '\x1F07' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI +foldMapping '\x1F90' = CM '\x1F20' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI +foldMapping '\x1F91' = CM '\x1F21' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1F92' = CM '\x1F22' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1F93' = CM '\x1F23' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1F94' = CM '\x1F24' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1F95' = CM '\x1F25' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1F96' = CM '\x1F26' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1F97' = CM '\x1F27' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI +foldMapping '\x1F98' = CM '\x1F20' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI +foldMapping '\x1F99' = CM '\x1F21' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1F9A' = CM '\x1F22' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1F9B' = CM '\x1F23' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1F9C' = CM '\x1F24' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1F9D' = CM '\x1F25' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1F9E' = CM '\x1F26' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1F9F' = CM '\x1F27' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI +foldMapping '\x1FA0' = CM '\x1F60' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI +foldMapping '\x1FA1' = CM '\x1F61' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1FA2' = CM '\x1F62' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1FA3' = CM '\x1F63' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1FA4' = CM '\x1F64' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1FA5' = CM '\x1F65' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1FA6' = CM '\x1F66' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1FA7' = CM '\x1F67' '\x03B9' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI +foldMapping '\x1FA8' = CM '\x1F60' '\x03B9' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI +foldMapping '\x1FA9' = CM '\x1F61' '\x03B9' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1FAA' = CM '\x1F62' '\x03B9' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1FAB' = CM '\x1F63' '\x03B9' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1FAC' = CM '\x1F64' '\x03B9' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1FAD' = CM '\x1F65' '\x03B9' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1FAE' = CM '\x1F66' '\x03B9' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1FAF' = CM '\x1F67' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI +foldMapping '\x1FB2' = CM '\x1F70' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI +foldMapping '\x1FB3' = CM '\x03B1' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI +foldMapping '\x1FB4' = CM '\x03AC' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI +foldMapping '\x1FB6' = CM '\x03B1' '\x0342' '\0' +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1FB7' = CM '\x03B1' '\x0342' '\x03B9' +-- GREEK CAPITAL LETTER ALPHA WITH VRACHY +foldMapping '\x1FB8' = CM '\x1FB0' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH MACRON +foldMapping '\x1FB9' = CM '\x1FB1' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH VARIA +foldMapping '\x1FBA' = CM '\x1F70' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH OXIA +foldMapping '\x1FBB' = CM '\x1F71' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI +foldMapping '\x1FBC' = CM '\x03B1' '\x03B9' '\0' +-- GREEK PROSGEGRAMMENI +foldMapping '\x1FBE' = CM '\x03B9' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI +foldMapping '\x1FC2' = CM '\x1F74' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI +foldMapping '\x1FC3' = CM '\x03B7' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI +foldMapping '\x1FC4' = CM '\x03AE' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH PERISPOMENI +foldMapping '\x1FC6' = CM '\x03B7' '\x0342' '\0' +-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1FC7' = CM '\x03B7' '\x0342' '\x03B9' +-- GREEK CAPITAL LETTER EPSILON WITH VARIA +foldMapping '\x1FC8' = CM '\x1F72' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON WITH OXIA +foldMapping '\x1FC9' = CM '\x1F73' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH VARIA +foldMapping '\x1FCA' = CM '\x1F74' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH OXIA +foldMapping '\x1FCB' = CM '\x1F75' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI +foldMapping '\x1FCC' = CM '\x03B7' '\x03B9' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA +foldMapping '\x1FD2' = CM '\x03B9' '\x0308' '\x0300' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA +foldMapping '\x1FD3' = CM '\x03B9' '\x0308' '\x0301' +-- GREEK SMALL LETTER IOTA WITH PERISPOMENI +foldMapping '\x1FD6' = CM '\x03B9' '\x0342' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI +foldMapping '\x1FD7' = CM '\x03B9' '\x0308' '\x0342' +-- GREEK CAPITAL LETTER IOTA WITH VRACHY +foldMapping '\x1FD8' = CM '\x1FD0' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH MACRON +foldMapping '\x1FD9' = CM '\x1FD1' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH VARIA +foldMapping '\x1FDA' = CM '\x1F76' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH OXIA +foldMapping '\x1FDB' = CM '\x1F77' '\0' '\0' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA +foldMapping '\x1FE2' = CM '\x03C5' '\x0308' '\x0300' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA +foldMapping '\x1FE3' = CM '\x03C5' '\x0308' '\x0301' +-- GREEK SMALL LETTER RHO WITH PSILI +foldMapping '\x1FE4' = CM '\x03C1' '\x0313' '\0' +-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI +foldMapping '\x1FE6' = CM '\x03C5' '\x0342' '\0' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI +foldMapping '\x1FE7' = CM '\x03C5' '\x0308' '\x0342' +-- GREEK CAPITAL LETTER UPSILON WITH VRACHY +foldMapping '\x1FE8' = CM '\x1FE0' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON WITH MACRON +foldMapping '\x1FE9' = CM '\x1FE1' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON WITH VARIA +foldMapping '\x1FEA' = CM '\x1F7A' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON WITH OXIA +foldMapping '\x1FEB' = CM '\x1F7B' '\0' '\0' +-- GREEK CAPITAL LETTER RHO WITH DASIA +foldMapping '\x1FEC' = CM '\x1FE5' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI +foldMapping '\x1FF2' = CM '\x1F7C' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI +foldMapping '\x1FF3' = CM '\x03C9' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI +foldMapping '\x1FF4' = CM '\x03CE' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI +foldMapping '\x1FF6' = CM '\x03C9' '\x0342' '\0' +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1FF7' = CM '\x03C9' '\x0342' '\x03B9' +-- GREEK CAPITAL LETTER OMICRON WITH VARIA +foldMapping '\x1FF8' = CM '\x1F78' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON WITH OXIA +foldMapping '\x1FF9' = CM '\x1F79' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH VARIA +foldMapping '\x1FFA' = CM '\x1F7C' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH OXIA +foldMapping '\x1FFB' = CM '\x1F7D' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI +foldMapping '\x1FFC' = CM '\x03C9' '\x03B9' '\0' +-- OHM SIGN +foldMapping '\x2126' = CM '\x03C9' '\0' '\0' +-- KELVIN SIGN +foldMapping '\x212A' = CM '\x006B' '\0' '\0' +-- ANGSTROM SIGN +foldMapping '\x212B' = CM '\x00E5' '\0' '\0' +-- TURNED CAPITAL F +foldMapping '\x2132' = CM '\x214E' '\0' '\0' +-- ROMAN NUMERAL ONE +foldMapping '\x2160' = CM '\x2170' '\0' '\0' +-- ROMAN NUMERAL TWO +foldMapping '\x2161' = CM '\x2171' '\0' '\0' +-- ROMAN NUMERAL THREE +foldMapping '\x2162' = CM '\x2172' '\0' '\0' +-- ROMAN NUMERAL FOUR +foldMapping '\x2163' = CM '\x2173' '\0' '\0' +-- ROMAN NUMERAL FIVE +foldMapping '\x2164' = CM '\x2174' '\0' '\0' +-- ROMAN NUMERAL SIX +foldMapping '\x2165' = CM '\x2175' '\0' '\0' +-- ROMAN NUMERAL SEVEN +foldMapping '\x2166' = CM '\x2176' '\0' '\0' +-- ROMAN NUMERAL EIGHT +foldMapping '\x2167' = CM '\x2177' '\0' '\0' +-- ROMAN NUMERAL NINE +foldMapping '\x2168' = CM '\x2178' '\0' '\0' +-- ROMAN NUMERAL TEN +foldMapping '\x2169' = CM '\x2179' '\0' '\0' +-- ROMAN NUMERAL ELEVEN +foldMapping '\x216A' = CM '\x217A' '\0' '\0' +-- ROMAN NUMERAL TWELVE +foldMapping '\x216B' = CM '\x217B' '\0' '\0' +-- ROMAN NUMERAL FIFTY +foldMapping '\x216C' = CM '\x217C' '\0' '\0' +-- ROMAN NUMERAL ONE HUNDRED +foldMapping '\x216D' = CM '\x217D' '\0' '\0' +-- ROMAN NUMERAL FIVE HUNDRED +foldMapping '\x216E' = CM '\x217E' '\0' '\0' +-- ROMAN NUMERAL ONE THOUSAND +foldMapping '\x216F' = CM '\x217F' '\0' '\0' +-- ROMAN NUMERAL REVERSED ONE HUNDRED +foldMapping '\x2183' = CM '\x2184' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER A +foldMapping '\x24B6' = CM '\x24D0' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER B +foldMapping '\x24B7' = CM '\x24D1' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER C +foldMapping '\x24B8' = CM '\x24D2' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER D +foldMapping '\x24B9' = CM '\x24D3' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER E +foldMapping '\x24BA' = CM '\x24D4' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER F +foldMapping '\x24BB' = CM '\x24D5' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER G +foldMapping '\x24BC' = CM '\x24D6' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER H +foldMapping '\x24BD' = CM '\x24D7' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER I +foldMapping '\x24BE' = CM '\x24D8' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER J +foldMapping '\x24BF' = CM '\x24D9' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER K +foldMapping '\x24C0' = CM '\x24DA' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER L +foldMapping '\x24C1' = CM '\x24DB' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER M +foldMapping '\x24C2' = CM '\x24DC' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER N +foldMapping '\x24C3' = CM '\x24DD' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER O +foldMapping '\x24C4' = CM '\x24DE' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER P +foldMapping '\x24C5' = CM '\x24DF' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER Q +foldMapping '\x24C6' = CM '\x24E0' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER R +foldMapping '\x24C7' = CM '\x24E1' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER S +foldMapping '\x24C8' = CM '\x24E2' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER T +foldMapping '\x24C9' = CM '\x24E3' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER U +foldMapping '\x24CA' = CM '\x24E4' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER V +foldMapping '\x24CB' = CM '\x24E5' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER W +foldMapping '\x24CC' = CM '\x24E6' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER X +foldMapping '\x24CD' = CM '\x24E7' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER Y +foldMapping '\x24CE' = CM '\x24E8' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER Z +foldMapping '\x24CF' = CM '\x24E9' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER AZU +foldMapping '\x2C00' = CM '\x2C30' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER BUKY +foldMapping '\x2C01' = CM '\x2C31' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER VEDE +foldMapping '\x2C02' = CM '\x2C32' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER GLAGOLI +foldMapping '\x2C03' = CM '\x2C33' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER DOBRO +foldMapping '\x2C04' = CM '\x2C34' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER YESTU +foldMapping '\x2C05' = CM '\x2C35' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER ZHIVETE +foldMapping '\x2C06' = CM '\x2C36' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER DZELO +foldMapping '\x2C07' = CM '\x2C37' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER ZEMLJA +foldMapping '\x2C08' = CM '\x2C38' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER IZHE +foldMapping '\x2C09' = CM '\x2C39' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER INITIAL IZHE +foldMapping '\x2C0A' = CM '\x2C3A' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER I +foldMapping '\x2C0B' = CM '\x2C3B' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER DJERVI +foldMapping '\x2C0C' = CM '\x2C3C' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER KAKO +foldMapping '\x2C0D' = CM '\x2C3D' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER LJUDIJE +foldMapping '\x2C0E' = CM '\x2C3E' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER MYSLITE +foldMapping '\x2C0F' = CM '\x2C3F' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER NASHI +foldMapping '\x2C10' = CM '\x2C40' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER ONU +foldMapping '\x2C11' = CM '\x2C41' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER POKOJI +foldMapping '\x2C12' = CM '\x2C42' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER RITSI +foldMapping '\x2C13' = CM '\x2C43' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER SLOVO +foldMapping '\x2C14' = CM '\x2C44' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER TVRIDO +foldMapping '\x2C15' = CM '\x2C45' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER UKU +foldMapping '\x2C16' = CM '\x2C46' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER FRITU +foldMapping '\x2C17' = CM '\x2C47' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER HERU +foldMapping '\x2C18' = CM '\x2C48' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER OTU +foldMapping '\x2C19' = CM '\x2C49' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER PE +foldMapping '\x2C1A' = CM '\x2C4A' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER SHTA +foldMapping '\x2C1B' = CM '\x2C4B' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER TSI +foldMapping '\x2C1C' = CM '\x2C4C' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER CHRIVI +foldMapping '\x2C1D' = CM '\x2C4D' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER SHA +foldMapping '\x2C1E' = CM '\x2C4E' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER YERU +foldMapping '\x2C1F' = CM '\x2C4F' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER YERI +foldMapping '\x2C20' = CM '\x2C50' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER YATI +foldMapping '\x2C21' = CM '\x2C51' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER SPIDERY HA +foldMapping '\x2C22' = CM '\x2C52' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER YU +foldMapping '\x2C23' = CM '\x2C53' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER SMALL YUS +foldMapping '\x2C24' = CM '\x2C54' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER SMALL YUS WITH TAIL +foldMapping '\x2C25' = CM '\x2C55' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER YO +foldMapping '\x2C26' = CM '\x2C56' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER IOTATED SMALL YUS +foldMapping '\x2C27' = CM '\x2C57' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER BIG YUS +foldMapping '\x2C28' = CM '\x2C58' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER IOTATED BIG YUS +foldMapping '\x2C29' = CM '\x2C59' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER FITA +foldMapping '\x2C2A' = CM '\x2C5A' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER IZHITSA +foldMapping '\x2C2B' = CM '\x2C5B' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER SHTAPIC +foldMapping '\x2C2C' = CM '\x2C5C' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER TROKUTASTI A +foldMapping '\x2C2D' = CM '\x2C5D' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE +foldMapping '\x2C2E' = CM '\x2C5E' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH DOUBLE BAR +foldMapping '\x2C60' = CM '\x2C61' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH MIDDLE TILDE +foldMapping '\x2C62' = CM '\x026B' '\0' '\0' +-- LATIN CAPITAL LETTER P WITH STROKE +foldMapping '\x2C63' = CM '\x1D7D' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH TAIL +foldMapping '\x2C64' = CM '\x027D' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH DESCENDER +foldMapping '\x2C67' = CM '\x2C68' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH DESCENDER +foldMapping '\x2C69' = CM '\x2C6A' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH DESCENDER +foldMapping '\x2C6B' = CM '\x2C6C' '\0' '\0' +-- LATIN CAPITAL LETTER ALPHA +foldMapping '\x2C6D' = CM '\x0251' '\0' '\0' +-- LATIN CAPITAL LETTER M WITH HOOK +foldMapping '\x2C6E' = CM '\x0271' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED A +foldMapping '\x2C6F' = CM '\x0250' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED ALPHA +foldMapping '\x2C70' = CM '\x0252' '\0' '\0' +-- LATIN CAPITAL LETTER W WITH HOOK +foldMapping '\x2C72' = CM '\x2C73' '\0' '\0' +-- LATIN CAPITAL LETTER HALF H +foldMapping '\x2C75' = CM '\x2C76' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH SWASH TAIL +foldMapping '\x2C7E' = CM '\x023F' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH SWASH TAIL +foldMapping '\x2C7F' = CM '\x0240' '\0' '\0' +-- COPTIC CAPITAL LETTER ALFA +foldMapping '\x2C80' = CM '\x2C81' '\0' '\0' +-- COPTIC CAPITAL LETTER VIDA +foldMapping '\x2C82' = CM '\x2C83' '\0' '\0' +-- COPTIC CAPITAL LETTER GAMMA +foldMapping '\x2C84' = CM '\x2C85' '\0' '\0' +-- COPTIC CAPITAL LETTER DALDA +foldMapping '\x2C86' = CM '\x2C87' '\0' '\0' +-- COPTIC CAPITAL LETTER EIE +foldMapping '\x2C88' = CM '\x2C89' '\0' '\0' +-- COPTIC CAPITAL LETTER SOU +foldMapping '\x2C8A' = CM '\x2C8B' '\0' '\0' +-- COPTIC CAPITAL LETTER ZATA +foldMapping '\x2C8C' = CM '\x2C8D' '\0' '\0' +-- COPTIC CAPITAL LETTER HATE +foldMapping '\x2C8E' = CM '\x2C8F' '\0' '\0' +-- COPTIC CAPITAL LETTER THETHE +foldMapping '\x2C90' = CM '\x2C91' '\0' '\0' +-- COPTIC CAPITAL LETTER IAUDA +foldMapping '\x2C92' = CM '\x2C93' '\0' '\0' +-- COPTIC CAPITAL LETTER KAPA +foldMapping '\x2C94' = CM '\x2C95' '\0' '\0' +-- COPTIC CAPITAL LETTER LAULA +foldMapping '\x2C96' = CM '\x2C97' '\0' '\0' +-- COPTIC CAPITAL LETTER MI +foldMapping '\x2C98' = CM '\x2C99' '\0' '\0' +-- COPTIC CAPITAL LETTER NI +foldMapping '\x2C9A' = CM '\x2C9B' '\0' '\0' +-- COPTIC CAPITAL LETTER KSI +foldMapping '\x2C9C' = CM '\x2C9D' '\0' '\0' +-- COPTIC CAPITAL LETTER O +foldMapping '\x2C9E' = CM '\x2C9F' '\0' '\0' +-- COPTIC CAPITAL LETTER PI +foldMapping '\x2CA0' = CM '\x2CA1' '\0' '\0' +-- COPTIC CAPITAL LETTER RO +foldMapping '\x2CA2' = CM '\x2CA3' '\0' '\0' +-- COPTIC CAPITAL LETTER SIMA +foldMapping '\x2CA4' = CM '\x2CA5' '\0' '\0' +-- COPTIC CAPITAL LETTER TAU +foldMapping '\x2CA6' = CM '\x2CA7' '\0' '\0' +-- COPTIC CAPITAL LETTER UA +foldMapping '\x2CA8' = CM '\x2CA9' '\0' '\0' +-- COPTIC CAPITAL LETTER FI +foldMapping '\x2CAA' = CM '\x2CAB' '\0' '\0' +-- COPTIC CAPITAL LETTER KHI +foldMapping '\x2CAC' = CM '\x2CAD' '\0' '\0' +-- COPTIC CAPITAL LETTER PSI +foldMapping '\x2CAE' = CM '\x2CAF' '\0' '\0' +-- COPTIC CAPITAL LETTER OOU +foldMapping '\x2CB0' = CM '\x2CB1' '\0' '\0' +-- COPTIC CAPITAL LETTER DIALECT-P ALEF +foldMapping '\x2CB2' = CM '\x2CB3' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC AIN +foldMapping '\x2CB4' = CM '\x2CB5' '\0' '\0' +-- COPTIC CAPITAL LETTER CRYPTOGRAMMIC EIE +foldMapping '\x2CB6' = CM '\x2CB7' '\0' '\0' +-- COPTIC CAPITAL LETTER DIALECT-P KAPA +foldMapping '\x2CB8' = CM '\x2CB9' '\0' '\0' +-- COPTIC CAPITAL LETTER DIALECT-P NI +foldMapping '\x2CBA' = CM '\x2CBB' '\0' '\0' +-- COPTIC CAPITAL LETTER CRYPTOGRAMMIC NI +foldMapping '\x2CBC' = CM '\x2CBD' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC OOU +foldMapping '\x2CBE' = CM '\x2CBF' '\0' '\0' +-- COPTIC CAPITAL LETTER SAMPI +foldMapping '\x2CC0' = CM '\x2CC1' '\0' '\0' +-- COPTIC CAPITAL LETTER CROSSED SHEI +foldMapping '\x2CC2' = CM '\x2CC3' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC SHEI +foldMapping '\x2CC4' = CM '\x2CC5' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC ESH +foldMapping '\x2CC6' = CM '\x2CC7' '\0' '\0' +-- COPTIC CAPITAL LETTER AKHMIMIC KHEI +foldMapping '\x2CC8' = CM '\x2CC9' '\0' '\0' +-- COPTIC CAPITAL LETTER DIALECT-P HORI +foldMapping '\x2CCA' = CM '\x2CCB' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC HORI +foldMapping '\x2CCC' = CM '\x2CCD' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC HA +foldMapping '\x2CCE' = CM '\x2CCF' '\0' '\0' +-- COPTIC CAPITAL LETTER L-SHAPED HA +foldMapping '\x2CD0' = CM '\x2CD1' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC HEI +foldMapping '\x2CD2' = CM '\x2CD3' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC HAT +foldMapping '\x2CD4' = CM '\x2CD5' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC GANGIA +foldMapping '\x2CD6' = CM '\x2CD7' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC DJA +foldMapping '\x2CD8' = CM '\x2CD9' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC SHIMA +foldMapping '\x2CDA' = CM '\x2CDB' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD NUBIAN SHIMA +foldMapping '\x2CDC' = CM '\x2CDD' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD NUBIAN NGI +foldMapping '\x2CDE' = CM '\x2CDF' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD NUBIAN NYI +foldMapping '\x2CE0' = CM '\x2CE1' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD NUBIAN WAU +foldMapping '\x2CE2' = CM '\x2CE3' '\0' '\0' +-- COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI +foldMapping '\x2CEB' = CM '\x2CEC' '\0' '\0' +-- COPTIC CAPITAL LETTER CRYPTOGRAMMIC GANGIA +foldMapping '\x2CED' = CM '\x2CEE' '\0' '\0' +-- COPTIC CAPITAL LETTER BOHAIRIC KHEI +foldMapping '\x2CF2' = CM '\x2CF3' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZEMLYA +foldMapping '\xA640' = CM '\xA641' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DZELO +foldMapping '\xA642' = CM '\xA643' '\0' '\0' +-- CYRILLIC CAPITAL LETTER REVERSED DZE +foldMapping '\xA644' = CM '\xA645' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IOTA +foldMapping '\xA646' = CM '\xA647' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DJERV +foldMapping '\xA648' = CM '\xA649' '\0' '\0' +-- CYRILLIC CAPITAL LETTER MONOGRAPH UK +foldMapping '\xA64A' = CM '\xA64B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BROAD OMEGA +foldMapping '\xA64C' = CM '\xA64D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER NEUTRAL YER +foldMapping '\xA64E' = CM '\xA64F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YERU WITH BACK YER +foldMapping '\xA650' = CM '\xA651' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IOTIFIED YAT +foldMapping '\xA652' = CM '\xA653' '\0' '\0' +-- CYRILLIC CAPITAL LETTER REVERSED YU +foldMapping '\xA654' = CM '\xA655' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IOTIFIED A +foldMapping '\xA656' = CM '\xA657' '\0' '\0' +-- CYRILLIC CAPITAL LETTER CLOSED LITTLE YUS +foldMapping '\xA658' = CM '\xA659' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BLENDED YUS +foldMapping '\xA65A' = CM '\xA65B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IOTIFIED CLOSED LITTLE YUS +foldMapping '\xA65C' = CM '\xA65D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YN +foldMapping '\xA65E' = CM '\xA65F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER REVERSED TSE +foldMapping '\xA660' = CM '\xA661' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SOFT DE +foldMapping '\xA662' = CM '\xA663' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SOFT EL +foldMapping '\xA664' = CM '\xA665' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SOFT EM +foldMapping '\xA666' = CM '\xA667' '\0' '\0' +-- CYRILLIC CAPITAL LETTER MONOCULAR O +foldMapping '\xA668' = CM '\xA669' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BINOCULAR O +foldMapping '\xA66A' = CM '\xA66B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DOUBLE MONOCULAR O +foldMapping '\xA66C' = CM '\xA66D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DWE +foldMapping '\xA680' = CM '\xA681' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DZWE +foldMapping '\xA682' = CM '\xA683' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZHWE +foldMapping '\xA684' = CM '\xA685' '\0' '\0' +-- CYRILLIC CAPITAL LETTER CCHE +foldMapping '\xA686' = CM '\xA687' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DZZE +foldMapping '\xA688' = CM '\xA689' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TE WITH MIDDLE HOOK +foldMapping '\xA68A' = CM '\xA68B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TWE +foldMapping '\xA68C' = CM '\xA68D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TSWE +foldMapping '\xA68E' = CM '\xA68F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TSSE +foldMapping '\xA690' = CM '\xA691' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TCHE +foldMapping '\xA692' = CM '\xA693' '\0' '\0' +-- CYRILLIC CAPITAL LETTER HWE +foldMapping '\xA694' = CM '\xA695' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SHWE +foldMapping '\xA696' = CM '\xA697' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DOUBLE O +foldMapping '\xA698' = CM '\xA699' '\0' '\0' +-- CYRILLIC CAPITAL LETTER CROSSED O +foldMapping '\xA69A' = CM '\xA69B' '\0' '\0' +-- LATIN CAPITAL LETTER EGYPTOLOGICAL ALEF +foldMapping '\xA722' = CM '\xA723' '\0' '\0' +-- LATIN CAPITAL LETTER EGYPTOLOGICAL AIN +foldMapping '\xA724' = CM '\xA725' '\0' '\0' +-- LATIN CAPITAL LETTER HENG +foldMapping '\xA726' = CM '\xA727' '\0' '\0' +-- LATIN CAPITAL LETTER TZ +foldMapping '\xA728' = CM '\xA729' '\0' '\0' +-- LATIN CAPITAL LETTER TRESILLO +foldMapping '\xA72A' = CM '\xA72B' '\0' '\0' +-- LATIN CAPITAL LETTER CUATRILLO +foldMapping '\xA72C' = CM '\xA72D' '\0' '\0' +-- LATIN CAPITAL LETTER CUATRILLO WITH COMMA +foldMapping '\xA72E' = CM '\xA72F' '\0' '\0' +-- LATIN CAPITAL LETTER AA +foldMapping '\xA732' = CM '\xA733' '\0' '\0' +-- LATIN CAPITAL LETTER AO +foldMapping '\xA734' = CM '\xA735' '\0' '\0' +-- LATIN CAPITAL LETTER AU +foldMapping '\xA736' = CM '\xA737' '\0' '\0' +-- LATIN CAPITAL LETTER AV +foldMapping '\xA738' = CM '\xA739' '\0' '\0' +-- LATIN CAPITAL LETTER AV WITH HORIZONTAL BAR +foldMapping '\xA73A' = CM '\xA73B' '\0' '\0' +-- LATIN CAPITAL LETTER AY +foldMapping '\xA73C' = CM '\xA73D' '\0' '\0' +-- LATIN CAPITAL LETTER REVERSED C WITH DOT +foldMapping '\xA73E' = CM '\xA73F' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH STROKE +foldMapping '\xA740' = CM '\xA741' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH DIAGONAL STROKE +foldMapping '\xA742' = CM '\xA743' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH STROKE AND DIAGONAL STROKE +foldMapping '\xA744' = CM '\xA745' '\0' '\0' +-- LATIN CAPITAL LETTER BROKEN L +foldMapping '\xA746' = CM '\xA747' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH HIGH STROKE +foldMapping '\xA748' = CM '\xA749' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH LONG STROKE OVERLAY +foldMapping '\xA74A' = CM '\xA74B' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH LOOP +foldMapping '\xA74C' = CM '\xA74D' '\0' '\0' +-- LATIN CAPITAL LETTER OO +foldMapping '\xA74E' = CM '\xA74F' '\0' '\0' +-- LATIN CAPITAL LETTER P WITH STROKE THROUGH DESCENDER +foldMapping '\xA750' = CM '\xA751' '\0' '\0' +-- LATIN CAPITAL LETTER P WITH FLOURISH +foldMapping '\xA752' = CM '\xA753' '\0' '\0' +-- LATIN CAPITAL LETTER P WITH SQUIRREL TAIL +foldMapping '\xA754' = CM '\xA755' '\0' '\0' +-- LATIN CAPITAL LETTER Q WITH STROKE THROUGH DESCENDER +foldMapping '\xA756' = CM '\xA757' '\0' '\0' +-- LATIN CAPITAL LETTER Q WITH DIAGONAL STROKE +foldMapping '\xA758' = CM '\xA759' '\0' '\0' +-- LATIN CAPITAL LETTER R ROTUNDA +foldMapping '\xA75A' = CM '\xA75B' '\0' '\0' +-- LATIN CAPITAL LETTER RUM ROTUNDA +foldMapping '\xA75C' = CM '\xA75D' '\0' '\0' +-- LATIN CAPITAL LETTER V WITH DIAGONAL STROKE +foldMapping '\xA75E' = CM '\xA75F' '\0' '\0' +-- LATIN CAPITAL LETTER VY +foldMapping '\xA760' = CM '\xA761' '\0' '\0' +-- LATIN CAPITAL LETTER VISIGOTHIC Z +foldMapping '\xA762' = CM '\xA763' '\0' '\0' +-- LATIN CAPITAL LETTER THORN WITH STROKE +foldMapping '\xA764' = CM '\xA765' '\0' '\0' +-- LATIN CAPITAL LETTER THORN WITH STROKE THROUGH DESCENDER +foldMapping '\xA766' = CM '\xA767' '\0' '\0' +-- LATIN CAPITAL LETTER VEND +foldMapping '\xA768' = CM '\xA769' '\0' '\0' +-- LATIN CAPITAL LETTER ET +foldMapping '\xA76A' = CM '\xA76B' '\0' '\0' +-- LATIN CAPITAL LETTER IS +foldMapping '\xA76C' = CM '\xA76D' '\0' '\0' +-- LATIN CAPITAL LETTER CON +foldMapping '\xA76E' = CM '\xA76F' '\0' '\0' +-- LATIN CAPITAL LETTER INSULAR D +foldMapping '\xA779' = CM '\xA77A' '\0' '\0' +-- LATIN CAPITAL LETTER INSULAR F +foldMapping '\xA77B' = CM '\xA77C' '\0' '\0' +-- LATIN CAPITAL LETTER INSULAR G +foldMapping '\xA77D' = CM '\x1D79' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED INSULAR G +foldMapping '\xA77E' = CM '\xA77F' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED L +foldMapping '\xA780' = CM '\xA781' '\0' '\0' +-- LATIN CAPITAL LETTER INSULAR R +foldMapping '\xA782' = CM '\xA783' '\0' '\0' +-- LATIN CAPITAL LETTER INSULAR S +foldMapping '\xA784' = CM '\xA785' '\0' '\0' +-- LATIN CAPITAL LETTER INSULAR T +foldMapping '\xA786' = CM '\xA787' '\0' '\0' +-- LATIN CAPITAL LETTER SALTILLO +foldMapping '\xA78B' = CM '\xA78C' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED H +foldMapping '\xA78D' = CM '\x0265' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH DESCENDER +foldMapping '\xA790' = CM '\xA791' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH BAR +foldMapping '\xA792' = CM '\xA793' '\0' '\0' +-- LATIN CAPITAL LETTER B WITH FLOURISH +foldMapping '\xA796' = CM '\xA797' '\0' '\0' +-- LATIN CAPITAL LETTER F WITH STROKE +foldMapping '\xA798' = CM '\xA799' '\0' '\0' +-- LATIN CAPITAL LETTER VOLAPUK AE +foldMapping '\xA79A' = CM '\xA79B' '\0' '\0' +-- LATIN CAPITAL LETTER VOLAPUK OE +foldMapping '\xA79C' = CM '\xA79D' '\0' '\0' +-- LATIN CAPITAL LETTER VOLAPUK UE +foldMapping '\xA79E' = CM '\xA79F' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH OBLIQUE STROKE +foldMapping '\xA7A0' = CM '\xA7A1' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH OBLIQUE STROKE +foldMapping '\xA7A2' = CM '\xA7A3' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH OBLIQUE STROKE +foldMapping '\xA7A4' = CM '\xA7A5' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH OBLIQUE STROKE +foldMapping '\xA7A6' = CM '\xA7A7' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH OBLIQUE STROKE +foldMapping '\xA7A8' = CM '\xA7A9' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH HOOK +foldMapping '\xA7AA' = CM '\x0266' '\0' '\0' +-- LATIN CAPITAL LETTER REVERSED OPEN E +foldMapping '\xA7AB' = CM '\x025C' '\0' '\0' +-- LATIN CAPITAL LETTER SCRIPT G +foldMapping '\xA7AC' = CM '\x0261' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH BELT +foldMapping '\xA7AD' = CM '\x026C' '\0' '\0' +-- LATIN CAPITAL LETTER SMALL CAPITAL I +foldMapping '\xA7AE' = CM '\x026A' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED K +foldMapping '\xA7B0' = CM '\x029E' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED T +foldMapping '\xA7B1' = CM '\x0287' '\0' '\0' +-- LATIN CAPITAL LETTER J WITH CROSSED-TAIL +foldMapping '\xA7B2' = CM '\x029D' '\0' '\0' +-- LATIN CAPITAL LETTER CHI +foldMapping '\xA7B3' = CM '\xAB53' '\0' '\0' +-- LATIN CAPITAL LETTER BETA +foldMapping '\xA7B4' = CM '\xA7B5' '\0' '\0' +-- LATIN CAPITAL LETTER OMEGA +foldMapping '\xA7B6' = CM '\xA7B7' '\0' '\0' +-- CHEROKEE SMALL LETTER A +foldMapping '\xAB70' = CM '\x13A0' '\0' '\0' +-- CHEROKEE SMALL LETTER E +foldMapping '\xAB71' = CM '\x13A1' '\0' '\0' +-- CHEROKEE SMALL LETTER I +foldMapping '\xAB72' = CM '\x13A2' '\0' '\0' +-- CHEROKEE SMALL LETTER O +foldMapping '\xAB73' = CM '\x13A3' '\0' '\0' +-- CHEROKEE SMALL LETTER U +foldMapping '\xAB74' = CM '\x13A4' '\0' '\0' +-- CHEROKEE SMALL LETTER V +foldMapping '\xAB75' = CM '\x13A5' '\0' '\0' +-- CHEROKEE SMALL LETTER GA +foldMapping '\xAB76' = CM '\x13A6' '\0' '\0' +-- CHEROKEE SMALL LETTER KA +foldMapping '\xAB77' = CM '\x13A7' '\0' '\0' +-- CHEROKEE SMALL LETTER GE +foldMapping '\xAB78' = CM '\x13A8' '\0' '\0' +-- CHEROKEE SMALL LETTER GI +foldMapping '\xAB79' = CM '\x13A9' '\0' '\0' +-- CHEROKEE SMALL LETTER GO +foldMapping '\xAB7A' = CM '\x13AA' '\0' '\0' +-- CHEROKEE SMALL LETTER GU +foldMapping '\xAB7B' = CM '\x13AB' '\0' '\0' +-- CHEROKEE SMALL LETTER GV +foldMapping '\xAB7C' = CM '\x13AC' '\0' '\0' +-- CHEROKEE SMALL LETTER HA +foldMapping '\xAB7D' = CM '\x13AD' '\0' '\0' +-- CHEROKEE SMALL LETTER HE +foldMapping '\xAB7E' = CM '\x13AE' '\0' '\0' +-- CHEROKEE SMALL LETTER HI +foldMapping '\xAB7F' = CM '\x13AF' '\0' '\0' +-- CHEROKEE SMALL LETTER HO +foldMapping '\xAB80' = CM '\x13B0' '\0' '\0' +-- CHEROKEE SMALL LETTER HU +foldMapping '\xAB81' = CM '\x13B1' '\0' '\0' +-- CHEROKEE SMALL LETTER HV +foldMapping '\xAB82' = CM '\x13B2' '\0' '\0' +-- CHEROKEE SMALL LETTER LA +foldMapping '\xAB83' = CM '\x13B3' '\0' '\0' +-- CHEROKEE SMALL LETTER LE +foldMapping '\xAB84' = CM '\x13B4' '\0' '\0' +-- CHEROKEE SMALL LETTER LI +foldMapping '\xAB85' = CM '\x13B5' '\0' '\0' +-- CHEROKEE SMALL LETTER LO +foldMapping '\xAB86' = CM '\x13B6' '\0' '\0' +-- CHEROKEE SMALL LETTER LU +foldMapping '\xAB87' = CM '\x13B7' '\0' '\0' +-- CHEROKEE SMALL LETTER LV +foldMapping '\xAB88' = CM '\x13B8' '\0' '\0' +-- CHEROKEE SMALL LETTER MA +foldMapping '\xAB89' = CM '\x13B9' '\0' '\0' +-- CHEROKEE SMALL LETTER ME +foldMapping '\xAB8A' = CM '\x13BA' '\0' '\0' +-- CHEROKEE SMALL LETTER MI +foldMapping '\xAB8B' = CM '\x13BB' '\0' '\0' +-- CHEROKEE SMALL LETTER MO +foldMapping '\xAB8C' = CM '\x13BC' '\0' '\0' +-- CHEROKEE SMALL LETTER MU +foldMapping '\xAB8D' = CM '\x13BD' '\0' '\0' +-- CHEROKEE SMALL LETTER NA +foldMapping '\xAB8E' = CM '\x13BE' '\0' '\0' +-- CHEROKEE SMALL LETTER HNA +foldMapping '\xAB8F' = CM '\x13BF' '\0' '\0' +-- CHEROKEE SMALL LETTER NAH +foldMapping '\xAB90' = CM '\x13C0' '\0' '\0' +-- CHEROKEE SMALL LETTER NE +foldMapping '\xAB91' = CM '\x13C1' '\0' '\0' +-- CHEROKEE SMALL LETTER NI +foldMapping '\xAB92' = CM '\x13C2' '\0' '\0' +-- CHEROKEE SMALL LETTER NO +foldMapping '\xAB93' = CM '\x13C3' '\0' '\0' +-- CHEROKEE SMALL LETTER NU +foldMapping '\xAB94' = CM '\x13C4' '\0' '\0' +-- CHEROKEE SMALL LETTER NV +foldMapping '\xAB95' = CM '\x13C5' '\0' '\0' +-- CHEROKEE SMALL LETTER QUA +foldMapping '\xAB96' = CM '\x13C6' '\0' '\0' +-- CHEROKEE SMALL LETTER QUE +foldMapping '\xAB97' = CM '\x13C7' '\0' '\0' +-- CHEROKEE SMALL LETTER QUI +foldMapping '\xAB98' = CM '\x13C8' '\0' '\0' +-- CHEROKEE SMALL LETTER QUO +foldMapping '\xAB99' = CM '\x13C9' '\0' '\0' +-- CHEROKEE SMALL LETTER QUU +foldMapping '\xAB9A' = CM '\x13CA' '\0' '\0' +-- CHEROKEE SMALL LETTER QUV +foldMapping '\xAB9B' = CM '\x13CB' '\0' '\0' +-- CHEROKEE SMALL LETTER SA +foldMapping '\xAB9C' = CM '\x13CC' '\0' '\0' +-- CHEROKEE SMALL LETTER S +foldMapping '\xAB9D' = CM '\x13CD' '\0' '\0' +-- CHEROKEE SMALL LETTER SE +foldMapping '\xAB9E' = CM '\x13CE' '\0' '\0' +-- CHEROKEE SMALL LETTER SI +foldMapping '\xAB9F' = CM '\x13CF' '\0' '\0' +-- CHEROKEE SMALL LETTER SO +foldMapping '\xABA0' = CM '\x13D0' '\0' '\0' +-- CHEROKEE SMALL LETTER SU +foldMapping '\xABA1' = CM '\x13D1' '\0' '\0' +-- CHEROKEE SMALL LETTER SV +foldMapping '\xABA2' = CM '\x13D2' '\0' '\0' +-- CHEROKEE SMALL LETTER DA +foldMapping '\xABA3' = CM '\x13D3' '\0' '\0' +-- CHEROKEE SMALL LETTER TA +foldMapping '\xABA4' = CM '\x13D4' '\0' '\0' +-- CHEROKEE SMALL LETTER DE +foldMapping '\xABA5' = CM '\x13D5' '\0' '\0' +-- CHEROKEE SMALL LETTER TE +foldMapping '\xABA6' = CM '\x13D6' '\0' '\0' +-- CHEROKEE SMALL LETTER DI +foldMapping '\xABA7' = CM '\x13D7' '\0' '\0' +-- CHEROKEE SMALL LETTER TI +foldMapping '\xABA8' = CM '\x13D8' '\0' '\0' +-- CHEROKEE SMALL LETTER DO +foldMapping '\xABA9' = CM '\x13D9' '\0' '\0' +-- CHEROKEE SMALL LETTER DU +foldMapping '\xABAA' = CM '\x13DA' '\0' '\0' +-- CHEROKEE SMALL LETTER DV +foldMapping '\xABAB' = CM '\x13DB' '\0' '\0' +-- CHEROKEE SMALL LETTER DLA +foldMapping '\xABAC' = CM '\x13DC' '\0' '\0' +-- CHEROKEE SMALL LETTER TLA +foldMapping '\xABAD' = CM '\x13DD' '\0' '\0' +-- CHEROKEE SMALL LETTER TLE +foldMapping '\xABAE' = CM '\x13DE' '\0' '\0' +-- CHEROKEE SMALL LETTER TLI +foldMapping '\xABAF' = CM '\x13DF' '\0' '\0' +-- CHEROKEE SMALL LETTER TLO +foldMapping '\xABB0' = CM '\x13E0' '\0' '\0' +-- CHEROKEE SMALL LETTER TLU +foldMapping '\xABB1' = CM '\x13E1' '\0' '\0' +-- CHEROKEE SMALL LETTER TLV +foldMapping '\xABB2' = CM '\x13E2' '\0' '\0' +-- CHEROKEE SMALL LETTER TSA +foldMapping '\xABB3' = CM '\x13E3' '\0' '\0' +-- CHEROKEE SMALL LETTER TSE +foldMapping '\xABB4' = CM '\x13E4' '\0' '\0' +-- CHEROKEE SMALL LETTER TSI +foldMapping '\xABB5' = CM '\x13E5' '\0' '\0' +-- CHEROKEE SMALL LETTER TSO +foldMapping '\xABB6' = CM '\x13E6' '\0' '\0' +-- CHEROKEE SMALL LETTER TSU +foldMapping '\xABB7' = CM '\x13E7' '\0' '\0' +-- CHEROKEE SMALL LETTER TSV +foldMapping '\xABB8' = CM '\x13E8' '\0' '\0' +-- CHEROKEE SMALL LETTER WA +foldMapping '\xABB9' = CM '\x13E9' '\0' '\0' +-- CHEROKEE SMALL LETTER WE +foldMapping '\xABBA' = CM '\x13EA' '\0' '\0' +-- CHEROKEE SMALL LETTER WI +foldMapping '\xABBB' = CM '\x13EB' '\0' '\0' +-- CHEROKEE SMALL LETTER WO +foldMapping '\xABBC' = CM '\x13EC' '\0' '\0' +-- CHEROKEE SMALL LETTER WU +foldMapping '\xABBD' = CM '\x13ED' '\0' '\0' +-- CHEROKEE SMALL LETTER WV +foldMapping '\xABBE' = CM '\x13EE' '\0' '\0' +-- CHEROKEE SMALL LETTER YA +foldMapping '\xABBF' = CM '\x13EF' '\0' '\0' +-- LATIN SMALL LIGATURE FF +foldMapping '\xFB00' = CM '\x0066' '\x0066' '\0' +-- LATIN SMALL LIGATURE FI +foldMapping '\xFB01' = CM '\x0066' '\x0069' '\0' +-- LATIN SMALL LIGATURE FL +foldMapping '\xFB02' = CM '\x0066' '\x006C' '\0' +-- LATIN SMALL LIGATURE FFI +foldMapping '\xFB03' = CM '\x0066' '\x0066' '\x0069' +-- LATIN SMALL LIGATURE FFL +foldMapping '\xFB04' = CM '\x0066' '\x0066' '\x006C' +-- LATIN SMALL LIGATURE LONG S T +foldMapping '\xFB05' = CM '\x0073' '\x0074' '\0' +-- LATIN SMALL LIGATURE ST +foldMapping '\xFB06' = CM '\x0073' '\x0074' '\0' +-- ARMENIAN SMALL LIGATURE MEN NOW +foldMapping '\xFB13' = CM '\x0574' '\x0576' '\0' +-- ARMENIAN SMALL LIGATURE MEN ECH +foldMapping '\xFB14' = CM '\x0574' '\x0565' '\0' +-- ARMENIAN SMALL LIGATURE MEN INI +foldMapping '\xFB15' = CM '\x0574' '\x056B' '\0' +-- ARMENIAN SMALL LIGATURE VEW NOW +foldMapping '\xFB16' = CM '\x057E' '\x0576' '\0' +-- ARMENIAN SMALL LIGATURE MEN XEH +foldMapping '\xFB17' = CM '\x0574' '\x056D' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER A +foldMapping '\xFF21' = CM '\xFF41' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER B +foldMapping '\xFF22' = CM '\xFF42' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER C +foldMapping '\xFF23' = CM '\xFF43' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER D +foldMapping '\xFF24' = CM '\xFF44' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER E +foldMapping '\xFF25' = CM '\xFF45' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER F +foldMapping '\xFF26' = CM '\xFF46' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER G +foldMapping '\xFF27' = CM '\xFF47' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER H +foldMapping '\xFF28' = CM '\xFF48' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER I +foldMapping '\xFF29' = CM '\xFF49' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER J +foldMapping '\xFF2A' = CM '\xFF4A' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER K +foldMapping '\xFF2B' = CM '\xFF4B' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER L +foldMapping '\xFF2C' = CM '\xFF4C' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER M +foldMapping '\xFF2D' = CM '\xFF4D' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER N +foldMapping '\xFF2E' = CM '\xFF4E' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER O +foldMapping '\xFF2F' = CM '\xFF4F' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER P +foldMapping '\xFF30' = CM '\xFF50' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER Q +foldMapping '\xFF31' = CM '\xFF51' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER R +foldMapping '\xFF32' = CM '\xFF52' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER S +foldMapping '\xFF33' = CM '\xFF53' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER T +foldMapping '\xFF34' = CM '\xFF54' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER U +foldMapping '\xFF35' = CM '\xFF55' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER V +foldMapping '\xFF36' = CM '\xFF56' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER W +foldMapping '\xFF37' = CM '\xFF57' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER X +foldMapping '\xFF38' = CM '\xFF58' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER Y +foldMapping '\xFF39' = CM '\xFF59' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER Z +foldMapping '\xFF3A' = CM '\xFF5A' '\0' '\0' +-- DESERET CAPITAL LETTER LONG I +foldMapping '\x10400' = CM '\x10428' '\0' '\0' +-- DESERET CAPITAL LETTER LONG E +foldMapping '\x10401' = CM '\x10429' '\0' '\0' +-- DESERET CAPITAL LETTER LONG A +foldMapping '\x10402' = CM '\x1042A' '\0' '\0' +-- DESERET CAPITAL LETTER LONG AH +foldMapping '\x10403' = CM '\x1042B' '\0' '\0' +-- DESERET CAPITAL LETTER LONG O +foldMapping '\x10404' = CM '\x1042C' '\0' '\0' +-- DESERET CAPITAL LETTER LONG OO +foldMapping '\x10405' = CM '\x1042D' '\0' '\0' +-- DESERET CAPITAL LETTER SHORT I +foldMapping '\x10406' = CM '\x1042E' '\0' '\0' +-- DESERET CAPITAL LETTER SHORT E +foldMapping '\x10407' = CM '\x1042F' '\0' '\0' +-- DESERET CAPITAL LETTER SHORT A +foldMapping '\x10408' = CM '\x10430' '\0' '\0' +-- DESERET CAPITAL LETTER SHORT AH +foldMapping '\x10409' = CM '\x10431' '\0' '\0' +-- DESERET CAPITAL LETTER SHORT O +foldMapping '\x1040A' = CM '\x10432' '\0' '\0' +-- DESERET CAPITAL LETTER SHORT OO +foldMapping '\x1040B' = CM '\x10433' '\0' '\0' +-- DESERET CAPITAL LETTER AY +foldMapping '\x1040C' = CM '\x10434' '\0' '\0' +-- DESERET CAPITAL LETTER OW +foldMapping '\x1040D' = CM '\x10435' '\0' '\0' +-- DESERET CAPITAL LETTER WU +foldMapping '\x1040E' = CM '\x10436' '\0' '\0' +-- DESERET CAPITAL LETTER YEE +foldMapping '\x1040F' = CM '\x10437' '\0' '\0' +-- DESERET CAPITAL LETTER H +foldMapping '\x10410' = CM '\x10438' '\0' '\0' +-- DESERET CAPITAL LETTER PEE +foldMapping '\x10411' = CM '\x10439' '\0' '\0' +-- DESERET CAPITAL LETTER BEE +foldMapping '\x10412' = CM '\x1043A' '\0' '\0' +-- DESERET CAPITAL LETTER TEE +foldMapping '\x10413' = CM '\x1043B' '\0' '\0' +-- DESERET CAPITAL LETTER DEE +foldMapping '\x10414' = CM '\x1043C' '\0' '\0' +-- DESERET CAPITAL LETTER CHEE +foldMapping '\x10415' = CM '\x1043D' '\0' '\0' +-- DESERET CAPITAL LETTER JEE +foldMapping '\x10416' = CM '\x1043E' '\0' '\0' +-- DESERET CAPITAL LETTER KAY +foldMapping '\x10417' = CM '\x1043F' '\0' '\0' +-- DESERET CAPITAL LETTER GAY +foldMapping '\x10418' = CM '\x10440' '\0' '\0' +-- DESERET CAPITAL LETTER EF +foldMapping '\x10419' = CM '\x10441' '\0' '\0' +-- DESERET CAPITAL LETTER VEE +foldMapping '\x1041A' = CM '\x10442' '\0' '\0' +-- DESERET CAPITAL LETTER ETH +foldMapping '\x1041B' = CM '\x10443' '\0' '\0' +-- DESERET CAPITAL LETTER THEE +foldMapping '\x1041C' = CM '\x10444' '\0' '\0' +-- DESERET CAPITAL LETTER ES +foldMapping '\x1041D' = CM '\x10445' '\0' '\0' +-- DESERET CAPITAL LETTER ZEE +foldMapping '\x1041E' = CM '\x10446' '\0' '\0' +-- DESERET CAPITAL LETTER ESH +foldMapping '\x1041F' = CM '\x10447' '\0' '\0' +-- DESERET CAPITAL LETTER ZHEE +foldMapping '\x10420' = CM '\x10448' '\0' '\0' +-- DESERET CAPITAL LETTER ER +foldMapping '\x10421' = CM '\x10449' '\0' '\0' +-- DESERET CAPITAL LETTER EL +foldMapping '\x10422' = CM '\x1044A' '\0' '\0' +-- DESERET CAPITAL LETTER EM +foldMapping '\x10423' = CM '\x1044B' '\0' '\0' +-- DESERET CAPITAL LETTER EN +foldMapping '\x10424' = CM '\x1044C' '\0' '\0' +-- DESERET CAPITAL LETTER ENG +foldMapping '\x10425' = CM '\x1044D' '\0' '\0' +-- DESERET CAPITAL LETTER OI +foldMapping '\x10426' = CM '\x1044E' '\0' '\0' +-- DESERET CAPITAL LETTER EW +foldMapping '\x10427' = CM '\x1044F' '\0' '\0' +-- OSAGE CAPITAL LETTER A +foldMapping '\x104B0' = CM '\x104D8' '\0' '\0' +-- OSAGE CAPITAL LETTER AI +foldMapping '\x104B1' = CM '\x104D9' '\0' '\0' +-- OSAGE CAPITAL LETTER AIN +foldMapping '\x104B2' = CM '\x104DA' '\0' '\0' +-- OSAGE CAPITAL LETTER AH +foldMapping '\x104B3' = CM '\x104DB' '\0' '\0' +-- OSAGE CAPITAL LETTER BRA +foldMapping '\x104B4' = CM '\x104DC' '\0' '\0' +-- OSAGE CAPITAL LETTER CHA +foldMapping '\x104B5' = CM '\x104DD' '\0' '\0' +-- OSAGE CAPITAL LETTER EHCHA +foldMapping '\x104B6' = CM '\x104DE' '\0' '\0' +-- OSAGE CAPITAL LETTER E +foldMapping '\x104B7' = CM '\x104DF' '\0' '\0' +-- OSAGE CAPITAL LETTER EIN +foldMapping '\x104B8' = CM '\x104E0' '\0' '\0' +-- OSAGE CAPITAL LETTER HA +foldMapping '\x104B9' = CM '\x104E1' '\0' '\0' +-- OSAGE CAPITAL LETTER HYA +foldMapping '\x104BA' = CM '\x104E2' '\0' '\0' +-- OSAGE CAPITAL LETTER I +foldMapping '\x104BB' = CM '\x104E3' '\0' '\0' +-- OSAGE CAPITAL LETTER KA +foldMapping '\x104BC' = CM '\x104E4' '\0' '\0' +-- OSAGE CAPITAL LETTER EHKA +foldMapping '\x104BD' = CM '\x104E5' '\0' '\0' +-- OSAGE CAPITAL LETTER KYA +foldMapping '\x104BE' = CM '\x104E6' '\0' '\0' +-- OSAGE CAPITAL LETTER LA +foldMapping '\x104BF' = CM '\x104E7' '\0' '\0' +-- OSAGE CAPITAL LETTER MA +foldMapping '\x104C0' = CM '\x104E8' '\0' '\0' +-- OSAGE CAPITAL LETTER NA +foldMapping '\x104C1' = CM '\x104E9' '\0' '\0' +-- OSAGE CAPITAL LETTER O +foldMapping '\x104C2' = CM '\x104EA' '\0' '\0' +-- OSAGE CAPITAL LETTER OIN +foldMapping '\x104C3' = CM '\x104EB' '\0' '\0' +-- OSAGE CAPITAL LETTER PA +foldMapping '\x104C4' = CM '\x104EC' '\0' '\0' +-- OSAGE CAPITAL LETTER EHPA +foldMapping '\x104C5' = CM '\x104ED' '\0' '\0' +-- OSAGE CAPITAL LETTER SA +foldMapping '\x104C6' = CM '\x104EE' '\0' '\0' +-- OSAGE CAPITAL LETTER SHA +foldMapping '\x104C7' = CM '\x104EF' '\0' '\0' +-- OSAGE CAPITAL LETTER TA +foldMapping '\x104C8' = CM '\x104F0' '\0' '\0' +-- OSAGE CAPITAL LETTER EHTA +foldMapping '\x104C9' = CM '\x104F1' '\0' '\0' +-- OSAGE CAPITAL LETTER TSA +foldMapping '\x104CA' = CM '\x104F2' '\0' '\0' +-- OSAGE CAPITAL LETTER EHTSA +foldMapping '\x104CB' = CM '\x104F3' '\0' '\0' +-- OSAGE CAPITAL LETTER TSHA +foldMapping '\x104CC' = CM '\x104F4' '\0' '\0' +-- OSAGE CAPITAL LETTER DHA +foldMapping '\x104CD' = CM '\x104F5' '\0' '\0' +-- OSAGE CAPITAL LETTER U +foldMapping '\x104CE' = CM '\x104F6' '\0' '\0' +-- OSAGE CAPITAL LETTER WA +foldMapping '\x104CF' = CM '\x104F7' '\0' '\0' +-- OSAGE CAPITAL LETTER KHA +foldMapping '\x104D0' = CM '\x104F8' '\0' '\0' +-- OSAGE CAPITAL LETTER GHA +foldMapping '\x104D1' = CM '\x104F9' '\0' '\0' +-- OSAGE CAPITAL LETTER ZA +foldMapping '\x104D2' = CM '\x104FA' '\0' '\0' +-- OSAGE CAPITAL LETTER ZHA +foldMapping '\x104D3' = CM '\x104FB' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER A +foldMapping '\x10C80' = CM '\x10CC0' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER AA +foldMapping '\x10C81' = CM '\x10CC1' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EB +foldMapping '\x10C82' = CM '\x10CC2' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER AMB +foldMapping '\x10C83' = CM '\x10CC3' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EC +foldMapping '\x10C84' = CM '\x10CC4' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ENC +foldMapping '\x10C85' = CM '\x10CC5' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ECS +foldMapping '\x10C86' = CM '\x10CC6' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ED +foldMapping '\x10C87' = CM '\x10CC7' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER AND +foldMapping '\x10C88' = CM '\x10CC8' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER E +foldMapping '\x10C89' = CM '\x10CC9' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER CLOSE E +foldMapping '\x10C8A' = CM '\x10CCA' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EE +foldMapping '\x10C8B' = CM '\x10CCB' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EF +foldMapping '\x10C8C' = CM '\x10CCC' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EG +foldMapping '\x10C8D' = CM '\x10CCD' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EGY +foldMapping '\x10C8E' = CM '\x10CCE' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EH +foldMapping '\x10C8F' = CM '\x10CCF' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER I +foldMapping '\x10C90' = CM '\x10CD0' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER II +foldMapping '\x10C91' = CM '\x10CD1' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EJ +foldMapping '\x10C92' = CM '\x10CD2' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EK +foldMapping '\x10C93' = CM '\x10CD3' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER AK +foldMapping '\x10C94' = CM '\x10CD4' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER UNK +foldMapping '\x10C95' = CM '\x10CD5' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EL +foldMapping '\x10C96' = CM '\x10CD6' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ELY +foldMapping '\x10C97' = CM '\x10CD7' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EM +foldMapping '\x10C98' = CM '\x10CD8' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EN +foldMapping '\x10C99' = CM '\x10CD9' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ENY +foldMapping '\x10C9A' = CM '\x10CDA' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER O +foldMapping '\x10C9B' = CM '\x10CDB' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER OO +foldMapping '\x10C9C' = CM '\x10CDC' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER NIKOLSBURG OE +foldMapping '\x10C9D' = CM '\x10CDD' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER RUDIMENTA OE +foldMapping '\x10C9E' = CM '\x10CDE' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER OEE +foldMapping '\x10C9F' = CM '\x10CDF' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EP +foldMapping '\x10CA0' = CM '\x10CE0' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EMP +foldMapping '\x10CA1' = CM '\x10CE1' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ER +foldMapping '\x10CA2' = CM '\x10CE2' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER SHORT ER +foldMapping '\x10CA3' = CM '\x10CE3' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ES +foldMapping '\x10CA4' = CM '\x10CE4' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ESZ +foldMapping '\x10CA5' = CM '\x10CE5' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ET +foldMapping '\x10CA6' = CM '\x10CE6' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ENT +foldMapping '\x10CA7' = CM '\x10CE7' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ETY +foldMapping '\x10CA8' = CM '\x10CE8' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ECH +foldMapping '\x10CA9' = CM '\x10CE9' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER U +foldMapping '\x10CAA' = CM '\x10CEA' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER UU +foldMapping '\x10CAB' = CM '\x10CEB' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER NIKOLSBURG UE +foldMapping '\x10CAC' = CM '\x10CEC' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER RUDIMENTA UE +foldMapping '\x10CAD' = CM '\x10CED' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EV +foldMapping '\x10CAE' = CM '\x10CEE' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EZ +foldMapping '\x10CAF' = CM '\x10CEF' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EZS +foldMapping '\x10CB0' = CM '\x10CF0' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ENT-SHAPED SIGN +foldMapping '\x10CB1' = CM '\x10CF1' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER US +foldMapping '\x10CB2' = CM '\x10CF2' '\0' '\0' +-- WARANG CITI CAPITAL LETTER NGAA +foldMapping '\x118A0' = CM '\x118C0' '\0' '\0' +-- WARANG CITI CAPITAL LETTER A +foldMapping '\x118A1' = CM '\x118C1' '\0' '\0' +-- WARANG CITI CAPITAL LETTER WI +foldMapping '\x118A2' = CM '\x118C2' '\0' '\0' +-- WARANG CITI CAPITAL LETTER YU +foldMapping '\x118A3' = CM '\x118C3' '\0' '\0' +-- WARANG CITI CAPITAL LETTER YA +foldMapping '\x118A4' = CM '\x118C4' '\0' '\0' +-- WARANG CITI CAPITAL LETTER YO +foldMapping '\x118A5' = CM '\x118C5' '\0' '\0' +-- WARANG CITI CAPITAL LETTER II +foldMapping '\x118A6' = CM '\x118C6' '\0' '\0' +-- WARANG CITI CAPITAL LETTER UU +foldMapping '\x118A7' = CM '\x118C7' '\0' '\0' +-- WARANG CITI CAPITAL LETTER E +foldMapping '\x118A8' = CM '\x118C8' '\0' '\0' +-- WARANG CITI CAPITAL LETTER O +foldMapping '\x118A9' = CM '\x118C9' '\0' '\0' +-- WARANG CITI CAPITAL LETTER ANG +foldMapping '\x118AA' = CM '\x118CA' '\0' '\0' +-- WARANG CITI CAPITAL LETTER GA +foldMapping '\x118AB' = CM '\x118CB' '\0' '\0' +-- WARANG CITI CAPITAL LETTER KO +foldMapping '\x118AC' = CM '\x118CC' '\0' '\0' +-- WARANG CITI CAPITAL LETTER ENY +foldMapping '\x118AD' = CM '\x118CD' '\0' '\0' +-- WARANG CITI CAPITAL LETTER YUJ +foldMapping '\x118AE' = CM '\x118CE' '\0' '\0' +-- WARANG CITI CAPITAL LETTER UC +foldMapping '\x118AF' = CM '\x118CF' '\0' '\0' +-- WARANG CITI CAPITAL LETTER ENN +foldMapping '\x118B0' = CM '\x118D0' '\0' '\0' +-- WARANG CITI CAPITAL LETTER ODD +foldMapping '\x118B1' = CM '\x118D1' '\0' '\0' +-- WARANG CITI CAPITAL LETTER TTE +foldMapping '\x118B2' = CM '\x118D2' '\0' '\0' +-- WARANG CITI CAPITAL LETTER NUNG +foldMapping '\x118B3' = CM '\x118D3' '\0' '\0' +-- WARANG CITI CAPITAL LETTER DA +foldMapping '\x118B4' = CM '\x118D4' '\0' '\0' +-- WARANG CITI CAPITAL LETTER AT +foldMapping '\x118B5' = CM '\x118D5' '\0' '\0' +-- WARANG CITI CAPITAL LETTER AM +foldMapping '\x118B6' = CM '\x118D6' '\0' '\0' +-- WARANG CITI CAPITAL LETTER BU +foldMapping '\x118B7' = CM '\x118D7' '\0' '\0' +-- WARANG CITI CAPITAL LETTER PU +foldMapping '\x118B8' = CM '\x118D8' '\0' '\0' +-- WARANG CITI CAPITAL LETTER HIYO +foldMapping '\x118B9' = CM '\x118D9' '\0' '\0' +-- WARANG CITI CAPITAL LETTER HOLO +foldMapping '\x118BA' = CM '\x118DA' '\0' '\0' +-- WARANG CITI CAPITAL LETTER HORR +foldMapping '\x118BB' = CM '\x118DB' '\0' '\0' +-- WARANG CITI CAPITAL LETTER HAR +foldMapping '\x118BC' = CM '\x118DC' '\0' '\0' +-- WARANG CITI CAPITAL LETTER SSUU +foldMapping '\x118BD' = CM '\x118DD' '\0' '\0' +-- WARANG CITI CAPITAL LETTER SII +foldMapping '\x118BE' = CM '\x118DE' '\0' '\0' +-- WARANG CITI CAPITAL LETTER VIYO +foldMapping '\x118BF' = CM '\x118DF' '\0' '\0' +-- ADLAM CAPITAL LETTER ALIF +foldMapping '\x1E900' = CM '\x1E922' '\0' '\0' +-- ADLAM CAPITAL LETTER DAALI +foldMapping '\x1E901' = CM '\x1E923' '\0' '\0' +-- ADLAM CAPITAL LETTER LAAM +foldMapping '\x1E902' = CM '\x1E924' '\0' '\0' +-- ADLAM CAPITAL LETTER MIIM +foldMapping '\x1E903' = CM '\x1E925' '\0' '\0' +-- ADLAM CAPITAL LETTER BA +foldMapping '\x1E904' = CM '\x1E926' '\0' '\0' +-- ADLAM CAPITAL LETTER SINNYIIYHE +foldMapping '\x1E905' = CM '\x1E927' '\0' '\0' +-- ADLAM CAPITAL LETTER PE +foldMapping '\x1E906' = CM '\x1E928' '\0' '\0' +-- ADLAM CAPITAL LETTER BHE +foldMapping '\x1E907' = CM '\x1E929' '\0' '\0' +-- ADLAM CAPITAL LETTER RA +foldMapping '\x1E908' = CM '\x1E92A' '\0' '\0' +-- ADLAM CAPITAL LETTER E +foldMapping '\x1E909' = CM '\x1E92B' '\0' '\0' +-- ADLAM CAPITAL LETTER FA +foldMapping '\x1E90A' = CM '\x1E92C' '\0' '\0' +-- ADLAM CAPITAL LETTER I +foldMapping '\x1E90B' = CM '\x1E92D' '\0' '\0' +-- ADLAM CAPITAL LETTER O +foldMapping '\x1E90C' = CM '\x1E92E' '\0' '\0' +-- ADLAM CAPITAL LETTER DHA +foldMapping '\x1E90D' = CM '\x1E92F' '\0' '\0' +-- ADLAM CAPITAL LETTER YHE +foldMapping '\x1E90E' = CM '\x1E930' '\0' '\0' +-- ADLAM CAPITAL LETTER WAW +foldMapping '\x1E90F' = CM '\x1E931' '\0' '\0' +-- ADLAM CAPITAL LETTER NUN +foldMapping '\x1E910' = CM '\x1E932' '\0' '\0' +-- ADLAM CAPITAL LETTER KAF +foldMapping '\x1E911' = CM '\x1E933' '\0' '\0' +-- ADLAM CAPITAL LETTER YA +foldMapping '\x1E912' = CM '\x1E934' '\0' '\0' +-- ADLAM CAPITAL LETTER U +foldMapping '\x1E913' = CM '\x1E935' '\0' '\0' +-- ADLAM CAPITAL LETTER JIIM +foldMapping '\x1E914' = CM '\x1E936' '\0' '\0' +-- ADLAM CAPITAL LETTER CHI +foldMapping '\x1E915' = CM '\x1E937' '\0' '\0' +-- ADLAM CAPITAL LETTER HA +foldMapping '\x1E916' = CM '\x1E938' '\0' '\0' +-- ADLAM CAPITAL LETTER QAAF +foldMapping '\x1E917' = CM '\x1E939' '\0' '\0' +-- ADLAM CAPITAL LETTER GA +foldMapping '\x1E918' = CM '\x1E93A' '\0' '\0' +-- ADLAM CAPITAL LETTER NYA +foldMapping '\x1E919' = CM '\x1E93B' '\0' '\0' +-- ADLAM CAPITAL LETTER TU +foldMapping '\x1E91A' = CM '\x1E93C' '\0' '\0' +-- ADLAM CAPITAL LETTER NHA +foldMapping '\x1E91B' = CM '\x1E93D' '\0' '\0' +-- ADLAM CAPITAL LETTER VA +foldMapping '\x1E91C' = CM '\x1E93E' '\0' '\0' +-- ADLAM CAPITAL LETTER KHA +foldMapping '\x1E91D' = CM '\x1E93F' '\0' '\0' +-- ADLAM CAPITAL LETTER GBE +foldMapping '\x1E91E' = CM '\x1E940' '\0' '\0' +-- ADLAM CAPITAL LETTER ZAL +foldMapping '\x1E91F' = CM '\x1E941' '\0' '\0' +-- ADLAM CAPITAL LETTER KPO +foldMapping '\x1E920' = CM '\x1E942' '\0' '\0' +-- ADLAM CAPITAL LETTER SHA +foldMapping '\x1E921' = CM '\x1E943' '\0' '\0' +foldMapping c = CM (toLower c) '\0' '\0' \ No newline at end of file diff --git a/bundled/Basement/String/Encoding/ASCII7.hs b/bundled/Basement/String/Encoding/ASCII7.hs new file mode 100644 index 0000000..bbaacd6 --- /dev/null +++ b/bundled/Basement/String/Encoding/ASCII7.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.String.Encoding.ASCII7 +-- License : BSD-style +-- Maintainer : Foundation +-- Stability : experimental +-- Portability : portable +-- + +{-# LANGUAGE MagicHash #-} + +module Basement.String.Encoding.ASCII7 + ( ASCII7(..) + , ASCII7_Invalid(..) + ) where + +import Basement.Compat.Base +import Basement.Compat.Primitive +import Basement.Types.OffsetSize +import Basement.Numerical.Additive +import Basement.Monad +import Basement.Bits + +import GHC.Prim (int2Word#, ord#) +import GHC.Word +import GHC.Types +import Basement.UArray +import Basement.UArray.Mutable (MUArray) +import Basement.MutableBuilder + +import Basement.String.Encoding.Encoding + +-- | validate a given byte is within ASCII characters encoring size +-- +-- This function check the 8th bit is set to 0 +-- +isAscii :: Word8 -> Bool +isAscii w = (w .&. 0x80) == 0 +{-# INLINE isAscii #-} + +data ASCII7_Invalid + = ByteOutOfBound Word8 + | CharNotAscii Char + deriving (Typeable, Show, Eq) +instance Exception ASCII7_Invalid + +data ASCII7 = ASCII7 + +instance Encoding ASCII7 where + type Unit ASCII7 = Word8 + type Error ASCII7 = ASCII7_Invalid + encodingNext _ = next + encodingWrite _ = write + +-- | consume an Ascii7 char and return the Unicode point and the position +-- of the next possible Ascii7 char +-- +next :: (Offset Word8 -> Word8) + -- ^ method to access a given byte + -> Offset Word8 + -- ^ index of the byte + -> Either ASCII7_Invalid (Char, Offset Word8) + -- ^ either successfully validated the ASCII char and returned the + -- next index or fail with an error +next getter off + | isAscii w8 = Right (toChar w, off + 1) + | otherwise = Left $ ByteOutOfBound w8 + where + !w8@(W8# w) = getter off + toChar :: Word8# -> Char + toChar a = C# (word8ToChar# w) + +-- Write ascii char +-- +-- > build 64 $ sequence_ write "this is a simple list of char..." +-- +write :: (PrimMonad st, Monad st) + => Char + -- ^ expecting it to be a valid Ascii character. + -- otherwise this function will throw an exception + -> Builder (UArray Word8) (MUArray Word8) Word8 st err () +write c + | c < toEnum 0x80 = builderAppend $ w8 c + | otherwise = throw $ CharNotAscii c + where + w8 :: Char -> Word8 + w8 (C# ch) = W8# (wordToWord8# (int2Word# (ord# ch))) diff --git a/bundled/Basement/String/Encoding/Encoding.hs b/bundled/Basement/String/Encoding/Encoding.hs new file mode 100644 index 0000000..0d45a47 --- /dev/null +++ b/bundled/Basement/String/Encoding/Encoding.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.String.Encoding.Encoding +-- License : BSD-style +-- Maintainer : Foundation +-- Stability : experimental +-- Portability : portable +-- + +{-# LANGUAGE FlexibleContexts #-} + +module Basement.String.Encoding.Encoding + ( Encoding(..) + , convertFromTo + ) where + +import Basement.Compat.Base +import Basement.Types.OffsetSize +import Basement.Monad +import Basement.PrimType +import Basement.MutableBuilder +import Basement.Numerical.Additive +import Basement.UArray (UArray) +import Basement.UArray.Mutable (MUArray) +import qualified Basement.UArray as Vec + +class Encoding encoding where + -- | the unit element use for the encoding. + -- i.e. Word8 for ASCII7 or UTF8, Word16 for UTF16... + -- + type Unit encoding + + -- | define the type of error handling you want to use for the + -- next function. + -- + -- > type Error UTF8 = Either UTF8_Invalid + -- + type Error encoding + + -- | consume an `Unit encoding` and return the Unicode point and the position + -- of the next possible `Unit encoding` + -- + encodingNext :: encoding + -- ^ only used for type deduction + -> (Offset (Unit encoding) -> Unit encoding) + -- ^ method to access a given `Unit encoding` + -- (see `unsafeIndexer`) + -> Offset (Unit encoding) + -- ^ offset of the `Unit encoding` where starts the + -- encoding of a given unicode + -> Either (Error encoding) (Char, Offset (Unit encoding)) -- ^ either successfully validated the `Unit encoding` + -- and returned the next offset or fail with an + -- `Error encoding` + + -- Write a unicode point encoded into one or multiple `Unit encoding` + -- + -- > build 64 $ sequence_ (write UTF8) "this is a simple list of char..." + -- + encodingWrite :: (PrimMonad st, Monad st) + => encoding + -- ^ only used for type deduction + -> Char + -- ^ the unicode character to encode + -> Builder (UArray (Unit encoding)) + (MUArray (Unit encoding)) + (Unit encoding) st err () + +-- | helper to convert a given Array in a given encoding into an array +-- with another encoding. +-- +-- This is a helper to convert from one String encoding to another. +-- This function is (quite) slow and needs some work. +-- +-- ``` +-- let s16 = ... -- string in UTF16 +-- -- create s8, a UTF8 String +-- let s8 = runST $ convertWith UTF16 UTF8 (toBytes s16) +-- +-- print s8 +-- ``` +-- +convertFromTo :: ( PrimMonad st, Monad st + , Encoding input, PrimType (Unit input) + , Encoding output, PrimType (Unit output) + ) + => input + -- ^ Input's encoding type + -> output + -- ^ Output's encoding type + -> UArray (Unit input) + -- ^ the input raw array + -> st (Either (Offset (Unit input), Error input) (UArray (Unit output))) +convertFromTo inputEncodingTy outputEncodingTy bytes + | Vec.null bytes = return . return $ mempty + | otherwise = Vec.unsafeIndexer bytes $ \t -> Vec.builderBuild 64 (loop azero t) + where + lastUnit = Vec.length bytes + + loop off getter + | off .==# lastUnit = return () + | otherwise = case encodingNext inputEncodingTy getter off of + Left err -> mFail (off, err) + Right (c, noff) -> encodingWrite outputEncodingTy c >> loop noff getter diff --git a/bundled/Basement/String/Encoding/ISO_8859_1.hs b/bundled/Basement/String/Encoding/ISO_8859_1.hs new file mode 100644 index 0000000..50d91c4 --- /dev/null +++ b/bundled/Basement/String/Encoding/ISO_8859_1.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.String.Encoding.ISO_8859_1 +-- License : BSD-style +-- Maintainer : Foundation +-- Stability : experimental +-- Portability : portable +-- + +{-# LANGUAGE MagicHash #-} + +module Basement.String.Encoding.ISO_8859_1 + ( ISO_8859_1(..) + , ISO_8859_1_Invalid(..) + ) where + +import Basement.Compat.Base +import Basement.Compat.Primitive +import Basement.Types.OffsetSize +import Basement.Numerical.Additive +import Basement.Monad + +import GHC.Prim (int2Word#, ord#) +import GHC.Word +import GHC.Types +import Basement.UArray +import Basement.UArray.Mutable (MUArray) +import Basement.MutableBuilder + +import Basement.String.Encoding.Encoding + +-- offset of size one +aone :: Offset Word8 +aone = Offset 1 + +data ISO_8859_1_Invalid + = NotISO_8859_1 Char + deriving (Typeable, Show, Eq) +instance Exception ISO_8859_1_Invalid + +data ISO_8859_1 = ISO_8859_1 + +instance Encoding ISO_8859_1 where + type Unit ISO_8859_1 = Word8 + type Error ISO_8859_1 = ISO_8859_1_Invalid + encodingNext _ = next + encodingWrite _ = write + +next :: (Offset Word8 -> Word8) + -> Offset Word8 + -> Either ISO_8859_1_Invalid (Char, Offset Word8) +next getter off = Right (toChar w, off + aone) + where + !(W8# w) = getter off + toChar :: Word8# -> Char + toChar a = C# (word8ToChar# w) + +write :: (PrimMonad st, Monad st) + => Char + -> Builder (UArray Word8) (MUArray Word8) Word8 st err () +write c@(C# ch) + | c <= toEnum 0xFF = builderAppend (W8# x) + | otherwise = throw $ NotISO_8859_1 c + where + x :: Word8# + !x = wordToWord8# (int2Word# (ord# ch)) diff --git a/bundled/Basement/String/Encoding/UTF16.hs b/bundled/Basement/String/Encoding/UTF16.hs new file mode 100644 index 0000000..aeb8b89 --- /dev/null +++ b/bundled/Basement/String/Encoding/UTF16.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.String.Encoding.UTF16 +-- License : BSD-style +-- Maintainer : Foundation +-- Stability : experimental +-- Portability : portable +-- +{-# LANGUAGE MagicHash #-} +module Basement.String.Encoding.UTF16 + ( UTF16(..) + , UTF16_Invalid(..) + ) where + +import GHC.Prim +import GHC.Word +import GHC.Types +import qualified Prelude +import Basement.Compat.Base +import Basement.Compat.Primitive +import Basement.IntegralConv +import Basement.Bits +import Basement.Types.OffsetSize +import Basement.Monad +import Basement.Numerical.Additive +import Basement.Numerical.Subtractive +import Basement.UArray +import Basement.UArray.Mutable (MUArray) +import Basement.MutableBuilder + +import Basement.String.Encoding.Encoding + +data UTF16_Invalid + = InvalidContinuation + | InvalidUnicode Char + deriving (Show, Eq, Typeable) +instance Exception UTF16_Invalid + +data UTF16 = UTF16 + +instance Encoding UTF16 where + type Unit UTF16 = Word16 + type Error UTF16 = UTF16_Invalid + encodingNext _ = next + encodingWrite _ = write + + +-- +-- U+0000 to U+D7FF and U+E000 to U+FFFF : 1 bytes +-- U+10000 to U+10FFFF : +-- * 0x010000 is subtracted from the code point, leaving a 20-bit number in the range 0..0x0FFFFF. +-- * The top ten bits (a number in the range 0..0x03FF) are added to 0xD800 to give the first 16-bit code unit +-- or high surrogate, which will be in the range 0xD800..0xDBFF. +-- * The low ten bits (also in the range 0..0x03FF) are added to 0xDC00 to give the second 16-bit code unit +-- or low surrogate, which will be in the range 0xDC00..0xDFFF. + +next :: (Offset Word16 -> Word16) + -> Offset Word16 + -> Either UTF16_Invalid (Char, Offset Word16) +next getter off + | h < 0xd800 = Right (toChar16 h, off + Offset 1) + | h >= 0xe000 = Right (toChar16 h, off + Offset 1) + | otherwise = nextContinuation + where + h :: Word16 + !h = getter off + + to32 :: Word16 -> Word32 + to32 (W16# w) = W32# (word16ToWord32# w) + + toChar16 :: Word16 -> Char + toChar16 (W16# w) = C# (word32ToChar# (word16ToWord32# w)) + + nextContinuation + | cont >= 0xdc00 && cont < 0xe00 = + let !(W32# w) = ((to32 h .&. 0x3ff) .<<. 10) .|. (to32 cont .&. 0x3ff) + in Right (C# (word32ToChar# w), off + Offset 2) + | otherwise = Left InvalidContinuation + where + cont :: Word16 + !cont = getter $ off + Offset 1 + +write :: (PrimMonad st, Monad st) + => Char + -> Builder (UArray Word16) (MUArray Word16) Word16 st err () +write c + | c < toEnum 0xd800 = builderAppend $ w16 c + | c > toEnum 0x10000 = let (w1, w2) = wHigh c in builderAppend w1 >> builderAppend w2 + | c > toEnum 0x10ffff = throw $ InvalidUnicode c + | c >= toEnum 0xe000 = builderAppend $ w16 c + | otherwise = throw $ InvalidUnicode c + where + w16 :: Char -> Word16 + w16 (C# ch) = W16# (wordToWord16# (int2Word# (ord# ch))) + + to16 :: Word32 -> Word16 + to16 = Prelude.fromIntegral + + wHigh :: Char -> (Word16, Word16) + wHigh (C# ch) = + let v = W32# (charToWord32# ch) - 0x10000 + in (0xdc00 .|. to16 (v .>>. 10), 0xd800 .|. to16 (v .&. 0x3ff)) diff --git a/bundled/Basement/String/Encoding/UTF32.hs b/bundled/Basement/String/Encoding/UTF32.hs new file mode 100644 index 0000000..cda1678 --- /dev/null +++ b/bundled/Basement/String/Encoding/UTF32.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.String.Encoding.UTF32 +-- License : BSD-style +-- Maintainer : Foundation +-- Stability : experimental +-- Portability : portable +-- +{-# LANGUAGE MagicHash #-} +module Basement.String.Encoding.UTF32 + ( UTF32(..) + , UTF32_Invalid + ) where + +import GHC.Prim +import GHC.Word +import GHC.Types +import Basement.Compat.Base +import Basement.Compat.Primitive +import Basement.Types.OffsetSize +import Basement.Monad +import Basement.Numerical.Additive +import Basement.UArray +import Basement.UArray.Mutable (MUArray) +import Basement.MutableBuilder + +import Basement.String.Encoding.Encoding + +data UTF32 = UTF32 + +data UTF32_Invalid = UTF32_Invalid + deriving (Typeable, Show, Eq, Ord, Enum, Bounded) +instance Exception UTF32_Invalid + +instance Encoding UTF32 where + type Unit UTF32 = Word32 + type Error UTF32 = UTF32_Invalid + encodingNext _ = next + encodingWrite _ = write + +next :: (Offset Word32 -> Word32) + -> Offset Word32 + -> Either UTF32_Invalid (Char, Offset Word32) +next getter off = Right (char, off + Offset 1) + where + !(W32# hh) = getter off + char :: Char + char = C# (word32ToChar# hh) + +write :: (PrimMonad st, Monad st) + => Char + -> Builder (UArray Word32) (MUArray Word32) Word32 st err () +write c = builderAppend w32 + where + !(C# ch) = c + w32 :: Word32 + w32 = W32# (charToWord32# ch) diff --git a/bundled/Basement/Terminal.hs b/bundled/Basement/Terminal.hs new file mode 100644 index 0000000..3665538 --- /dev/null +++ b/bundled/Basement/Terminal.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +module Basement.Terminal + ( initialize + , getDimensions + ) where + +import Basement.Compat.Base +import Basement.Terminal.Size (getDimensions) +#ifdef mingw32_HOST_OS +import System.IO (hSetEncoding, utf8, hPutStrLn, stderr, stdin, stdout) +import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP) +#endif + +initialize :: IO () +initialize = do +#ifdef mingw32_HOST_OS + query getConsoleOutputCP (\e -> setConsoleOutputCP e >> hSetEncoding stdout utf8 >> hSetEncoding stderr utf8) utf8Code + query getConsoleCP (\e -> setConsoleCP e >> hSetEncoding stdin utf8) utf8Code + where + utf8Code = 65001 + query get set expected = do + v <- get + if v == expected then pure () else set expected +#else + pure () +#endif diff --git a/bundled/Basement/Terminal/ANSI.hs b/bundled/Basement/Terminal/ANSI.hs new file mode 100644 index 0000000..6578b32 --- /dev/null +++ b/bundled/Basement/Terminal/ANSI.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Terminal.ANSI +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- +-- ANSI Terminal escape for cursor and attributes manipulations +-- +-- On Unix system, it should be supported by most terminal emulators. +-- +-- On Windows system, all escape sequences are empty for maximum +-- compatibility purpose, and easy implementation. newer version +-- of Windows 10 supports ANSI escape now, but we'll need +-- some kind of detection. +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +module Basement.Terminal.ANSI + ( + -- * Types + Escape + , Displacement + , ColorComponent + , GrayComponent + , RGBComponent + -- * Simple ANSI escape factory functions + , cursorUp + , cursorDown + , cursorForward + , cursorBack + , cursorNextLine + , cursorPrevLine + , cursorHorizontalAbsolute + , cursorPosition + , eraseScreenFromCursor + , eraseScreenToCursor + , eraseScreenAll + , eraseLineFromCursor + , eraseLineToCursor + , eraseLineAll + , scrollUp + , scrollDown + , sgrReset + , sgrForeground + , sgrBackground + , sgrForegroundGray24 + , sgrBackgroundGray24 + , sgrForegroundColor216 + , sgrBackgroundColor216 + ) where + +import Basement.String +import Basement.Bounded +import Basement.Imports +import Basement.Numerical.Multiplicative +import Basement.Numerical.Additive + +#ifndef mingw32_HOST_OS +#define SUPPORT_ANSI_ESCAPE +#endif + +type Escape = String + +type Displacement = Word64 + +-- | Simple color component on 8 color terminal (maximum compatibility) +type ColorComponent = Zn64 8 + +-- | Gray color compent on 256colors terminals +type GrayComponent = Zn64 24 + +-- | Color compent on 256colors terminals +type RGBComponent = Zn64 6 + +cursorUp, cursorDown, cursorForward, cursorBack + , cursorNextLine, cursorPrevLine + , cursorHorizontalAbsolute :: Displacement -> Escape +cursorUp n = csi1 n "A" +cursorDown n = csi1 n "B" +cursorForward n = csi1 n "C" +cursorBack n = csi1 n "D" +cursorNextLine n = csi1 n "E" +cursorPrevLine n = csi1 n "F" +cursorHorizontalAbsolute n = csi1 n "G" + +cursorPosition :: Displacement -> Displacement -> Escape +cursorPosition row col = csi2 row col "H" + +eraseScreenFromCursor + , eraseScreenToCursor + , eraseScreenAll + , eraseLineFromCursor + , eraseLineToCursor + , eraseLineAll :: Escape +eraseScreenFromCursor = csi1 0 "J" +eraseScreenToCursor = csi1 1 "J" +eraseScreenAll = csi1 2 "J" +eraseLineFromCursor = csi1 0 "K" +eraseLineToCursor = csi1 1 "K" +eraseLineAll = csi1 2 "K" + +scrollUp, scrollDown :: Displacement -> Escape +scrollUp n = csi1 n "S" +scrollDown n = csi1 n "T" + +-- | All attribute off +sgrReset :: Escape +sgrReset = csi1 0 "m" + +-- | 8 Colors + Bold attribute for foreground +sgrForeground :: ColorComponent -> Bool -> Escape +sgrForeground n bold + | bold = csi2 (30+unZn64 n) 1 "m" + | otherwise = csi1 (30+unZn64 n) "m" + +-- | 8 Colors + Bold attribute for background +sgrBackground :: ColorComponent -> Bool -> Escape +sgrBackground n bold + | bold = csi2 (40+unZn64 n) 1 "m" + | otherwise = csi1 (40+unZn64 n) "m" + +-- 256 colors mode + +sgrForegroundGray24, sgrBackgroundGray24 :: GrayComponent -> Escape +sgrForegroundGray24 v = csi3 38 5 (0xE8 + unZn64 v) "m" +sgrBackgroundGray24 v = csi3 48 5 (0xE8 + unZn64 v) "m" + +sgrForegroundColor216 :: RGBComponent -- ^ Red component + -> RGBComponent -- ^ Green component + -> RGBComponent -- ^ Blue component + -> Escape +sgrForegroundColor216 r g b = csi3 38 5 (0x10 + 36 * unZn64 r + 6 * unZn64 g + unZn64 b) "m" + +sgrBackgroundColor216 :: RGBComponent -- ^ Red component + -> RGBComponent -- ^ Green component + -> RGBComponent -- ^ Blue component + -> Escape +sgrBackgroundColor216 r g b = csi3 48 5 (0x10 + 36 * unZn64 r + 6 * unZn64 g + unZn64 b) "m" + +#ifdef SUPPORT_ANSI_ESCAPE + +csi0 :: String -> String +csi0 suffix = mconcat ["\ESC[", suffix] + +csi1 :: Displacement -> String -> String +csi1 p1 suffix = mconcat ["\ESC[", pshow p1, suffix] + +csi2 :: Displacement -> Displacement -> String -> String +csi2 p1 p2 suffix = mconcat ["\ESC[", pshow p1, ";", pshow p2, suffix] + +csi3 :: Displacement -> Displacement -> Displacement -> String -> String +csi3 p1 p2 p3 suffix = mconcat ["\ESC[", pshow p1, ";", pshow p2, ";", pshow p3, suffix] + +pshow = show + +#else + +csi0 :: String -> String +csi0 _ = "" + +csi1 :: Displacement -> String -> String +csi1 _ _ = "" + +csi2 :: Displacement -> Displacement -> String -> String +csi2 _ _ _ = "" + +csi3 :: Displacement -> Displacement -> Displacement -> String -> String +csi3 _ _ _ _ = "" + +#endif diff --git a/bundled/Basement/Terminal/Size.hsc b/bundled/Basement/Terminal/Size.hsc new file mode 100644 index 0000000..62c315e --- /dev/null +++ b/bundled/Basement/Terminal/Size.hsc @@ -0,0 +1,190 @@ +{-# LANGUAGE CApiFFI #-} +module Basement.Terminal.Size + ( getDimensions + ) where + +import Foreign +import Foreign.C +import Basement.Compat.Base +import Basement.Types.OffsetSize +import Basement.Numerical.Subtractive +import Basement.Numerical.Additive +import Prelude (fromIntegral) + +#include "foundation_system.h" +#ifdef FOUNDATION_SYSTEM_WINDOWS + +import System.Win32.Types (HANDLE, BOOL) +import Graphics.Win32.Misc (getStdHandle, sTD_OUTPUT_HANDLE, StdHandleId) + +#include +#elif defined FOUNDATION_SYSTEM_UNIX +#include +#ifdef __sun +#include +#endif +#endif + +#include + +#if __GLASGOW_HASKELL__ < 800 +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +#endif + +#ifdef FOUNDATION_SYSTEM_UNIX +data Winsize = Winsize + { ws_row :: !Word16 + , ws_col :: !Word16 + , ws_xpixel :: !Word16 + , ws_ypixel :: !Word16 + } + +instance Storable Winsize where + sizeOf _ = #{size struct winsize} + alignment _ = #{alignment struct winsize} + peek ptr = do + r <- #{peek struct winsize, ws_row} ptr + c <- #{peek struct winsize, ws_col} ptr + x <- #{peek struct winsize, ws_xpixel} ptr + y <- #{peek struct winsize, ws_ypixel} ptr + return (Winsize r c x y) + poke ptr (Winsize r c x y) = do + #{poke struct winsize, ws_row} ptr r + #{poke struct winsize, ws_col} ptr c + #{poke struct winsize, ws_xpixel} ptr x + #{poke struct winsize, ws_ypixel} ptr y + +#elif defined FOUNDATION_SYSTEM_WINDOWS +type Handle = Ptr CChar -- void * + +data SmallRect = SmallRect + { left :: !Int16 + , top :: !Int16 + , right :: !Int16 + , bottom :: !Int16 + } deriving (Show) + +instance Storable SmallRect where + sizeOf _ = #{size SMALL_RECT} + alignment _ = #{alignment SMALL_RECT} + peek ptr = do + l <- #{peek SMALL_RECT, Left} ptr + r <- #{peek SMALL_RECT, Right} ptr + t <- #{peek SMALL_RECT, Top} ptr + b <- #{peek SMALL_RECT, Bottom} ptr + return (SmallRect l t r b) + poke ptr (SmallRect l t r b) = do + #{poke SMALL_RECT, Left} ptr l + #{poke SMALL_RECT, Top} ptr t + #{poke SMALL_RECT, Right} ptr r + #{poke SMALL_RECT, Bottom} ptr b + +data Coord = Coord + { x :: !Int16 + , y :: !Int16 + } deriving (Show) + +instance Storable Coord where + sizeOf _ = #{size COORD} + alignment _ = #{alignment COORD} + peek ptr = do + x <- #{peek COORD, X} ptr + y <- #{peek COORD, Y} ptr + return (Coord x y) + poke ptr (Coord x y) = do + #{poke COORD, X} ptr x + #{poke COORD, Y} ptr y + +data ConsoleScreenBufferInfo = ConsoleScreenBufferInfo + { dwSize :: !Coord + , dwCursorPosition :: !Coord + , wAttributes :: !Word16 + , srWindow :: !SmallRect + , dwMaximumWindowSize :: !Coord + } deriving (Show) + +instance Storable ConsoleScreenBufferInfo where + sizeOf _ = #{size CONSOLE_SCREEN_BUFFER_INFO} + alignment _ = #{alignment CONSOLE_SCREEN_BUFFER_INFO} + peek ptr = do + s <- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwSize} ptr + c <- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition} ptr + a <- #{peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes} ptr + w <- #{peek CONSOLE_SCREEN_BUFFER_INFO, srWindow} ptr + m <- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize} ptr + return (ConsoleScreenBufferInfo s c a w m) + poke ptr (ConsoleScreenBufferInfo s c a w m) = do + #{poke CONSOLE_SCREEN_BUFFER_INFO, dwSize} ptr s + #{poke CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition} ptr c + #{poke CONSOLE_SCREEN_BUFFER_INFO, wAttributes} ptr a + #{poke CONSOLE_SCREEN_BUFFER_INFO, srWindow} ptr w + #{poke CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize} ptr m + +invalidHandleValue :: IntPtr +invalidHandleValue = #{const INVALID_HANDLE_VALUE} + +stdOutputHandle :: CULong +stdOutputHandle = #{const STD_OUTPUT_HANDLE} +#endif +-- defined FOUNDATION_SYSTEM_WINDOWS + +#ifdef FOUNDATION_SYSTEM_UNIX + +foreign import capi "sys/ioctl.h ioctl" c_ioctl :: CInt -> CULong -> Ptr a -> IO CInt + +-- | Get the terminal windows size +tiocgwinsz :: CULong +tiocgwinsz = Prelude.fromIntegral (#{const TIOCGWINSZ} :: Word) + +#elif defined FOUNDATION_SYSTEM_WINDOWS +foreign import ccall "GetConsoleScreenBufferInfo" c_get_console_screen_buffer_info + :: HANDLE -> Ptr ConsoleScreenBufferInfo -> IO BOOL +#endif + +#ifdef FOUNDATION_SYSTEM_UNIX +ioctlWinsize :: CInt -> IO (Maybe (CountOf Char, CountOf Char)) +ioctlWinsize fd = alloca $ \winsizePtr -> do + status <- c_ioctl fd tiocgwinsz winsizePtr + if status == (-1 :: CInt) + then pure Nothing + else Just . toDimensions <$> peek winsizePtr + where + toDimensions winsize = + ( CountOf . Prelude.fromIntegral . ws_col $ winsize + , CountOf . Prelude.fromIntegral . ws_row $ winsize) + +#elif defined FOUNDATION_SYSTEM_WINDOWS +getConsoleScreenBufferInfo :: HANDLE -> IO (Maybe ConsoleScreenBufferInfo) +getConsoleScreenBufferInfo handle = alloca $ \infoPtr -> do + status <- c_get_console_screen_buffer_info handle infoPtr + if status + then Just <$> peek infoPtr + else pure Nothing + +winWinsize :: StdHandleId -> IO (Maybe (CountOf Char, CountOf Char)) +winWinsize handleRef = (infoToDimensions <$>) <$> + (getStdHandle handleRef >>= getConsoleScreenBufferInfo) + where + infoToDimensions info = + let window = srWindow info + width = Prelude.fromIntegral (right window - left window + 1) + height = Prelude.fromIntegral (bottom window - top window + 1) + in (CountOf width, CountOf height) +#endif +-- defined FOUNDATION_SYSTEM_WINDOWS + +-- | Return the size of the current terminal +-- +-- If the system is not supported or that querying the system result in an error +-- then a default size of (80, 24) will be given back. +getDimensions :: IO (CountOf Char, CountOf Char) +getDimensions = +#if defined FOUNDATION_SYSTEM_WINDOWS + maybe defaultSize id <$> winWinsize sTD_OUTPUT_HANDLE +#elif defined FOUNDATION_SYSTEM_UNIX + maybe defaultSize id <$> ioctlWinsize 0 +#else + pure defaultSize +#endif + where + defaultSize = (80, 24) diff --git a/bundled/Basement/These.hs b/bundled/Basement/These.hs new file mode 100644 index 0000000..27eb66a --- /dev/null +++ b/bundled/Basement/These.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.These +-- License : BSD-style +-- Maintainer : Nicolas Di Prima +-- Stability : stable +-- Portability : portable +-- +-- @These a b@, sum type to represent either @a@ or @b@ or both. +-- +module Basement.These + ( These(..) + ) where + +import Basement.Compat.Base +import Basement.NormalForm + +-- | Either a or b or both. +data These a b + = This a + | That b + | These a b + deriving (Eq, Ord, Show, Typeable) + +instance (NormalForm a, NormalForm b) => NormalForm (These a b) where + toNormalForm (This a) = toNormalForm a + toNormalForm (That b) = toNormalForm b + toNormalForm (These a b) = toNormalForm a `seq` toNormalForm b diff --git a/bundled/Basement/Types/AsciiString.hs b/bundled/Basement/Types/AsciiString.hs new file mode 100644 index 0000000..9fbcbad --- /dev/null +++ b/bundled/Basement/Types/AsciiString.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Foundation.Primitives.Types.AsciiString +-- License : BSD-style +-- Maintainer : Haskell Foundation +-- Stability : experimental +-- Portability : portable +-- +-- A AsciiString type backed by a `ASCII` encoded byte array and all the necessary +-- functions to manipulate the string. +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Basement.Types.AsciiString + ( AsciiString(..) + , MutableAsciiString(..) + -- * Binary conversion + , fromBytesUnsafe + , fromBytes + ) where + +import Basement.Compat.Base +import Basement.Compat.Semigroup +import Basement.Types.Char7 +import Basement.UArray.Base +import qualified Basement.Types.Char7 as Char7 +import qualified Basement.UArray as A (all, unsafeRecast) + +-- | Opaque packed array of characters in the ASCII encoding +newtype AsciiString = AsciiString { toBytes :: UArray Char7 } + deriving (Typeable, Semigroup, Monoid, Eq, Ord) + +newtype MutableAsciiString st = MutableAsciiString (MUArray Char7 st) + deriving (Typeable) + +instance Show AsciiString where + show = fmap Char7.toChar . toList +instance IsString AsciiString where + fromString = fromList . fmap Char7.fromCharMask +instance IsList AsciiString where + type Item AsciiString = Char7 + fromList = AsciiString . fromList + toList (AsciiString chars) = toList chars + +-- | Convert a Byte Array representing ASCII data directly to an AsciiString without checking for ASCII validity +-- +-- If the input contains invalid Char7 value (anything above 0x7f), +-- it will trigger runtime async errors when processing data. +-- +-- In doubt, use 'fromBytes' +fromBytesUnsafe :: UArray Word8 -> AsciiString +fromBytesUnsafe = AsciiString . A.unsafeRecast + +-- | Convert a Byte Array representing ASCII checking validity. +-- +-- If the byte array is not valid, then Nothing is returned +fromBytes :: UArray Word8 -> Maybe AsciiString +fromBytes arr + | A.all (\x -> x < 0x80) arr = Just $ AsciiString $ A.unsafeRecast arr + | otherwise = Nothing diff --git a/bundled/Basement/Types/Char7.hs b/bundled/Basement/Types/Char7.hs new file mode 100644 index 0000000..003677e --- /dev/null +++ b/bundled/Basement/Types/Char7.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +module Basement.Types.Char7 + ( Char7(..) + , toChar + , fromCharMask + , fromChar + , fromByteMask + , fromByte + -- * individual ASCII Characters + , c7_LF + , c7_CR + , c7_minus + , c7_a + , c7_A + , c7_z + , c7_Z + , c7_0 + , c7_1 + , c7_2 + , c7_3 + , c7_4 + , c7_5 + , c7_6 + , c7_7 + , c7_8 + , c7_9 + -- * Upper / Lower With ASCII + , c7Upper + , c7Lower + ) where + +import GHC.Prim +import GHC.Word +import GHC.Types +import Data.Bits +import Data.Maybe +import Basement.Compat.Base +import Basement.Compat.Primitive + +-- | ASCII value between 0x0 and 0x7f +newtype Char7 = Char7 { toByte :: Word8 } + deriving (Show,Eq,Ord,Typeable) + +-- | Convert a 'Char7' to a unicode code point 'Char' +toChar :: Char7 -> Char +toChar !(Char7 (W8# w)) = C# (chr# (word2Int# (word8ToWord# w))) + +-- | Try to convert a 'Char' to a 'Char7' +-- +-- If the code point is non ascii, then Nothing is returned. +fromChar :: Char -> Maybe Char7 +fromChar !(C# c#) + | bool# (ltChar# c# (chr# 0x80#)) = Just $ Char7 $ W8# (wordToWord8# (int2Word# (ord# c#))) + | otherwise = Nothing + +-- | Try to convert 'Word8' to a 'Char7' +-- +-- If the byte got higher bit set, then Nothing is returned. +fromByte :: Word8 -> Maybe Char7 +fromByte !w + | (w .&. 0x80) == 0 = Just $ Char7 w + | otherwise = Nothing + +-- | Convert a 'Char' to a 'Char7' ignoring all higher bits +fromCharMask :: Char -> Char7 +fromCharMask !(C# c#) = Char7 $ W8# (wordToWord8# (and# (int2Word# (ord# c#)) 0x7f##)) + +-- | Convert a 'Byte' to a 'Char7' ignoring the higher bit +fromByteMask :: Word8 -> Char7 +fromByteMask !w = Char7 (w .&. 0x7f) + +c7_LF :: Char7 +c7_LF = Char7 0xa + +c7_CR :: Char7 +c7_CR = Char7 0xd + +c7_minus :: Char7 +c7_minus = Char7 0x2d + +c7_a :: Char7 +c7_a = Char7 0x61 + +c7_A :: Char7 +c7_A = Char7 0x41 + +c7_z :: Char7 +c7_z = Char7 0x7a + +c7_Z :: Char7 +c7_Z = Char7 0x5a + +c7_0, c7_1, c7_2, c7_3, c7_4, c7_5, c7_6, c7_7, c7_8, c7_9 :: Char7 +c7_0 = Char7 0x30 +c7_1 = Char7 0x31 +c7_2 = Char7 0x32 +c7_3 = Char7 0x33 +c7_4 = Char7 0x34 +c7_5 = Char7 0x35 +c7_6 = Char7 0x36 +c7_7 = Char7 0x37 +c7_8 = Char7 0x38 +c7_9 = Char7 0x39 + +c7Lower :: Char7 -> Char7 +c7Lower c@(Char7 w) + | c < c7_A = c + | c <= c7_Z = Char7 (w .|. 0x20) + | otherwise = c + +c7Upper :: Char7 -> Char7 +c7Upper c@(Char7 w) + | c < c7_a = c + | c <= c7_z = Char7 (w .&. 0xdf) + | otherwise = c diff --git a/bundled/Basement/Types/CharUTF8.hs b/bundled/Basement/Types/CharUTF8.hs new file mode 100644 index 0000000..a6514fa --- /dev/null +++ b/bundled/Basement/Types/CharUTF8.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Basement.Types.CharUTF8 + ( CharUTF8(..) + , encodeCharUTF8 + , decodeCharUTF8 + ) where + +import Basement.UTF8.Types +import Basement.UTF8.Helper diff --git a/bundled/Basement/Types/OffsetSize.hs b/bundled/Basement/Types/OffsetSize.hs new file mode 100644 index 0000000..bd82aad --- /dev/null +++ b/bundled/Basement/Types/OffsetSize.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.Types.OffsetSize +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# OPTIONS_GHC -fno-prof-auto #-} +module Basement.Types.OffsetSize + ( FileSize(..) + , Offset(..) + , Offset8 + , sentinel + , offsetOfE + , offsetPlusE + , offsetMinusE + , offsetRecast + , offsetCast + , offsetSub + , offsetShiftL + , offsetShiftR + , sizeCast + , sizeLastOffset + , sizeAsOffset + , sizeSub + , countOfRoundUp + , offsetAsSize + , (+.) + , (.==#) + , CountOf(..) + , sizeOfE + , csizeOfOffset + , csizeOfSize + , sizeOfCSSize + , sizeOfCSize + , Countable + , Offsetable + , natValCountOf + , natValOffset + ) where + +#include "MachDeps.h" + +import GHC.Types +import GHC.Word +import GHC.Int +import GHC.Prim +import qualified GHC.Prim +import System.Posix.Types (CSsize (..)) +import Data.Bits +import Basement.Compat.Base +import Basement.Compat.C.Types +import Basement.Compat.Semigroup +import Data.Proxy +import Basement.Numerical.Number +import Basement.Numerical.Additive +import Basement.Numerical.Subtractive +import Basement.Numerical.Multiplicative +import Basement.Numerical.Conversion (intToWord) +import Basement.Nat +import Basement.IntegralConv +import Data.List (foldl') +import qualified Prelude + +#if WORD_SIZE_IN_BITS < 64 +import GHC.IntWord64 +#endif + +-- | File size in bytes +newtype FileSize = FileSize Word64 + deriving (Show,Eq,Ord) + +-- | Offset in bytes used for memory addressing (e.g. in a vector, string, ..) +type Offset8 = Offset Word8 + +-- | Offset in a data structure consisting of elements of type 'ty'. +-- +-- Int is a terrible backing type which is hard to get away from, +-- considering that GHC/Haskell are mostly using this for offset. +-- Trying to bring some sanity by a lightweight wrapping. +newtype Offset ty = Offset Int + deriving (Show,Eq,Ord,Enum,Additive,Typeable,Integral,Prelude.Num) + +sentinel = Offset (-1) + +instance IsIntegral (Offset ty) where + toInteger (Offset i) = toInteger i +instance IsNatural (Offset ty) where + toNatural (Offset i) = toNatural (intToWord i) +instance Subtractive (Offset ty) where + type Difference (Offset ty) = CountOf ty + (Offset a) - (Offset b) = CountOf (a-b) + +(+.) :: Offset ty -> Int -> Offset ty +(+.) (Offset a) b = Offset (a + b) +{-# INLINE (+.) #-} + +-- . is offset (as a pointer from a beginning), and # is the size (amount of data) +(.==#) :: Offset ty -> CountOf ty -> Bool +(.==#) (Offset ofs) (CountOf sz) = ofs == sz +{-# INLINE (.==#) #-} + +offsetOfE :: CountOf Word8 -> Offset ty -> Offset8 +offsetOfE (CountOf sz) (Offset ty) = Offset (ty * sz) + +offsetPlusE :: Offset ty -> CountOf ty -> Offset ty +offsetPlusE (Offset ofs) (CountOf sz) = Offset (ofs + sz) + +offsetMinusE :: Offset ty -> CountOf ty -> Offset ty +offsetMinusE (Offset ofs) (CountOf sz) = Offset (ofs - sz) + +-- | subtract 2 CountOf values of the same type. +-- +-- m need to be greater than n, otherwise negative count error ensue +-- use the safer (-) version if unsure. +offsetSub :: Offset a -> Offset a -> Offset a +offsetSub (Offset m) (Offset n) = Offset (m - n) + +offsetRecast :: CountOf Word8 -> CountOf Word8 -> Offset ty -> Offset ty2 +offsetRecast szTy (CountOf szTy2) ofs = + let (Offset bytes) = offsetOfE szTy ofs + in Offset (bytes `div` szTy2) + +offsetShiftR :: Int -> Offset ty -> Offset ty2 +offsetShiftR n (Offset o) = Offset (o `unsafeShiftR` n) + +offsetShiftL :: Int -> Offset ty -> Offset ty2 +offsetShiftL n (Offset o) = Offset (o `unsafeShiftL` n) + +offsetCast :: Proxy (a -> b) -> Offset a -> Offset b +offsetCast _ (Offset o) = Offset o +{-# INLINE offsetCast #-} + +sizeCast :: Proxy (a -> b) -> CountOf a -> CountOf b +sizeCast _ (CountOf sz) = CountOf sz +{-# INLINE sizeCast #-} + +-- | subtract 2 CountOf values of the same type. +-- +-- m need to be greater than n, otherwise negative count error ensue +-- use the safer (-) version if unsure. +sizeSub :: CountOf a -> CountOf a -> CountOf a +sizeSub (CountOf m) (CountOf n) + | diff >= 0 = CountOf diff + | otherwise = error "sizeSub negative size" + where + diff = m - n + +-- TODO add a callstack, or a construction to prevent size == 0 error +sizeLastOffset :: CountOf a -> Offset a +sizeLastOffset (CountOf s) + | s > 0 = Offset (pred s) + | otherwise = error "last offset on size 0" + +sizeAsOffset :: CountOf a -> Offset a +sizeAsOffset (CountOf a) = Offset a +{-# INLINE sizeAsOffset #-} + +offsetAsSize :: Offset a -> CountOf a +offsetAsSize (Offset a) = CountOf a +{-# INLINE offsetAsSize #-} + +-- | CountOf of a data structure. +-- +-- More specifically, it represents the number of elements of type `ty` that fit +-- into the data structure. +-- +-- >>> length (fromList ['a', 'b', 'c', '🌟']) :: CountOf Char +-- CountOf 4 +-- +-- Same caveats as 'Offset' apply here. +newtype CountOf ty = CountOf Int + deriving (Show,Eq,Ord,Enum,Typeable,Integral) + +instance Prelude.Num (CountOf ty) where + fromInteger a = CountOf (fromInteger a) + (+) (CountOf a) (CountOf b) = CountOf (a+b) + (-) (CountOf a) (CountOf b) + | b > a = CountOf 0 + | otherwise = CountOf (a - b) + (*) (CountOf a) (CountOf b) = CountOf (a*b) + abs a = a + negate _ = error "cannot negate CountOf: use Foundation Numerical hierarchy for this function to not be exposed to CountOf" + signum (CountOf a) = CountOf (Prelude.signum a) + +instance IsIntegral (CountOf ty) where + toInteger (CountOf i) = toInteger i +instance IsNatural (CountOf ty) where + toNatural (CountOf i) = toNatural (intToWord i) + +instance Additive (CountOf ty) where + azero = CountOf 0 + (+) (CountOf a) (CountOf b) = CountOf (a+b) + scale n (CountOf a) = CountOf (scale n a) + +instance Subtractive (CountOf ty) where + type Difference (CountOf ty) = Maybe (CountOf ty) + (CountOf a) - (CountOf b) | a >= b = Just . CountOf $ a - b + | otherwise = Nothing + +instance Semigroup (CountOf ty) where + (<>) = (+) + +instance Monoid (CountOf ty) where + mempty = azero + mconcat = foldl' (+) 0 + +sizeOfE :: CountOf Word8 -> CountOf ty -> CountOf Word8 +sizeOfE (CountOf sz) (CountOf ty) = CountOf (ty * sz) + +-- | alignment need to be a power of 2 +countOfRoundUp :: Int -> CountOf ty -> CountOf ty +countOfRoundUp alignment (CountOf n) = CountOf ((n + (alignment-1)) .&. complement (alignment-1)) + +-- when #if WORD_SIZE_IN_BITS < 64 the 2 following are wrong +-- instead of using FromIntegral and being silently wrong +-- explicit pattern match to sort it out. + +csizeOfSize :: CountOf Word8 -> CSize +#if WORD_SIZE_IN_BITS < 64 +csizeOfSize (CountOf (I# sz)) = CSize (W32# (int2Word# sz)) +#else +#if __GLASGOW_HASKELL__ >= 904 +csizeOfSize (CountOf (I# sz)) = CSize (W64# (wordToWord64# (int2Word# sz))) + +#else +csizeOfSize (CountOf (I# sz)) = CSize (W64# (int2Word# sz)) + +#endif +#endif + +csizeOfOffset :: Offset8 -> CSize +#if WORD_SIZE_IN_BITS < 64 +csizeOfOffset (Offset (I# sz)) = CSize (W32# (int2Word# sz)) +#else +#if __GLASGOW_HASKELL__ >= 904 +csizeOfOffset (Offset (I# sz)) = CSize (W64# (wordToWord64# (int2Word# sz))) +#else +csizeOfOffset (Offset (I# sz)) = CSize (W64# (int2Word# sz)) +#endif +#endif + +sizeOfCSSize :: CSsize -> CountOf Word8 +sizeOfCSSize (CSsize (-1)) = error "invalid size: CSSize is -1" +#if WORD_SIZE_IN_BITS < 64 +sizeOfCSSize (CSsize (I32# sz)) = CountOf (I# sz) +#else +#if __GLASGOW_HASKELL__ >= 904 +sizeOfCSSize (CSsize (I64# sz)) = CountOf (I# (int64ToInt# sz)) +#else +sizeOfCSSize (CSsize (I64# sz)) = CountOf (I# sz) +#endif +#endif + +sizeOfCSize :: CSize -> CountOf Word8 +#if WORD_SIZE_IN_BITS < 64 +sizeOfCSize (CSize (W32# sz)) = CountOf (I# (word2Int# sz)) +#else +#if __GLASGOW_HASKELL__ >= 904 +sizeOfCSize (CSize (W64# sz)) = CountOf (I# (word2Int# (word64ToWord# sz))) +#else +sizeOfCSize (CSize (W64# sz)) = CountOf (I# (word2Int# sz)) +#endif +#endif + +natValCountOf :: forall n ty proxy . (KnownNat n, NatWithinBound (CountOf ty) n) => proxy n -> CountOf ty +natValCountOf n = CountOf $ Prelude.fromIntegral (natVal n) + +natValOffset :: forall n ty proxy . (KnownNat n, NatWithinBound (Offset ty) n) => proxy n -> Offset ty +natValOffset n = Offset $ Prelude.fromIntegral (natVal n) + +type instance NatNumMaxBound (CountOf x) = NatNumMaxBound Int +type instance NatNumMaxBound (Offset x) = NatNumMaxBound Int + +type Countable ty n = NatWithinBound (CountOf ty) n +type Offsetable ty n = NatWithinBound (Offset ty) n diff --git a/bundled/Basement/Types/Ptr.hs b/bundled/Basement/Types/Ptr.hs new file mode 100644 index 0000000..e249711 --- /dev/null +++ b/bundled/Basement/Types/Ptr.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} +module Basement.Types.Ptr + ( Addr(..) + , addrPlus + , addrPlusSz + , addrPlusCSz + , Ptr(..) + , ptrPlus + , ptrPlusSz + , ptrPlusCSz + , castPtr + ) where + +import Basement.Compat.Base +import Basement.Compat.C.Types +import Basement.Types.OffsetSize +import GHC.Ptr +import GHC.Prim +import GHC.Types + +data Addr = Addr Addr# + deriving (Eq,Ord) + +addrPlus :: Addr -> Offset Word8 -> Addr +addrPlus (Addr addr) (Offset (I# i)) = Addr (plusAddr# addr i) + +addrPlusSz :: Addr -> CountOf Word8 -> Addr +addrPlusSz (Addr addr) (CountOf (I# i)) = Addr (plusAddr# addr i) + +addrPlusCSz :: Addr -> CSize -> Addr +addrPlusCSz addr = addrPlusSz addr . sizeOfCSize + +ptrPlus :: Ptr a -> Offset Word8 -> Ptr a +ptrPlus (Ptr addr) (Offset (I# i)) = Ptr (plusAddr# addr i) + +ptrPlusSz :: Ptr a -> CountOf Word8 -> Ptr a +ptrPlusSz (Ptr addr) (CountOf (I# i)) = Ptr (plusAddr# addr i) + +ptrPlusCSz :: Ptr a -> CSize -> Ptr a +ptrPlusCSz ptr = ptrPlusSz ptr . sizeOfCSize diff --git a/bundled/Basement/Types/Word128.hs b/bundled/Basement/Types/Word128.hs new file mode 100644 index 0000000..9f81179 --- /dev/null +++ b/bundled/Basement/Types/Word128.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Basement.Types.Word128 + ( Word128(..) + , (+) + , (-) + , (*) + , quot + , rem + , bitwiseAnd + , bitwiseOr + , bitwiseXor + , complement + , shiftL + , shiftR + , rotateL + , rotateR + , popCount + , fromNatural + ) where + +import GHC.Prim +import GHC.Word +import GHC.Types +import qualified Prelude (fromInteger, show, Num(..), quot, rem, mod) +import Data.Bits hiding (complement, popCount, bit, testBit + , rotateL, rotateR, shiftL, shiftR) +import qualified Data.Bits as Bits +import Data.Function (on) +import Foreign.C +import Foreign.Ptr +import Foreign.Storable + +import Basement.Compat.Base +import Basement.Compat.Natural +import Basement.Compat.Primitive (bool#) +import Basement.Numerical.Conversion +import Basement.Numerical.Number + +#include "MachDeps.h" + +-- | 128 bits Word +data Word128 = Word128 {-# UNPACK #-} !Word64 + {-# UNPACK #-} !Word64 + deriving (Eq, Typeable) + +instance Show Word128 where + show w = Prelude.show (toNatural w) +instance Enum Word128 where + toEnum i = Word128 0 $ int64ToWord64 (intToInt64 i) + fromEnum (Word128 _ a0) = wordToInt (word64ToWord a0) + succ (Word128 a1 a0) + | a0 == maxBound = Word128 (succ a1) 0 + | otherwise = Word128 a1 (succ a0) + pred (Word128 a1 a0) + | a0 == minBound = Word128 (pred a1) maxBound + | otherwise = Word128 a1 (pred a0) +instance Bounded Word128 where + minBound = Word128 minBound minBound + maxBound = Word128 maxBound maxBound +instance Ord Word128 where + compare (Word128 a1 a0) (Word128 b1 b0) = + case compare a1 b1 of + EQ -> compare a0 b0 + r -> r + (<) (Word128 a1 a0) (Word128 b1 b0) = + case compare a1 b1 of + EQ -> a0 < b0 + r -> r == LT + (<=) (Word128 a1 a0) (Word128 b1 b0) = + case compare a1 b1 of + EQ -> a0 <= b0 + r -> r == LT +instance Storable Word128 where + sizeOf _ = 16 + alignment _ = 16 + peek p = Word128 <$> peek (castPtr p ) + <*> peek (castPtr p `plusPtr` 8) + poke p (Word128 a1 a0) = do + poke (castPtr p ) a1 + poke (castPtr p `plusPtr` 8) a0 + +instance Integral Word128 where + fromInteger = literal +instance HasNegation Word128 where + negate = complement + +instance IsIntegral Word128 where + toInteger (Word128 a1 a0) = + (toInteger a1 `unsafeShiftL` 64) .|. + toInteger a0 +instance IsNatural Word128 where + toNatural (Word128 a1 a0) = + (toNatural a1 `unsafeShiftL` 64) .|. + toNatural a0 + +instance Prelude.Num Word128 where + abs w = w + signum w@(Word128 a1 a0) + | a1 == 0 && a0 == 0 = w + | otherwise = Word128 0 1 + fromInteger = literal + (+) = (+) + (-) = (-) + (*) = (*) + +instance Bits.Bits Word128 where + (.&.) = bitwiseAnd + (.|.) = bitwiseOr + xor = bitwiseXor + complement = complement + shiftL = shiftL + shiftR = shiftR + rotateL = rotateL + rotateR = rotateR + bitSize _ = 128 + bitSizeMaybe _ = Just 128 + isSigned _ = False + testBit = testBit + bit = bit + popCount = popCount + +-- | Add 2 Word128 +(+) :: Word128 -> Word128 -> Word128 +#if WORD_SIZE_IN_BITS < 64 +(+) = applyBiWordOnNatural (Prelude.+) +#else +#if __GLASGOW_HASKELL__ >= 904 +(+) (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = Word128 (W64# s1) (W64# (wordToWord64# s0)) + where + !(# carry, s0 #) = plusWord2# (GHC.Prim.word64ToWord# a0) (GHC.Prim.word64ToWord# b0) + s1 = wordToWord64# (plusWord# (plusWord# (GHC.Prim.word64ToWord# a1) (GHC.Prim.word64ToWord# b1)) carry) +#else +(+) (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = Word128 (W64# s1) (W64# s0) + where + !(# carry, s0 #) = plusWord2# a0 b0 + s1 = plusWord# (plusWord# a1 b1) carry +#endif +#endif + +-- temporary available until native operation available +applyBiWordOnNatural :: (Natural -> Natural -> Natural) + -> Word128 + -> Word128 + -> Word128 +applyBiWordOnNatural f a b = fromNatural $ f (toNatural a) (toNatural b) + +-- | Subtract 2 Word128 +(-) :: Word128 -> Word128 -> Word128 +(-) a b + | a >= b = applyBiWordOnNatural (Prelude.-) a b + | otherwise = complement (applyBiWordOnNatural (Prelude.-) b a) + 1 + +-- | Multiplication +(*) :: Word128 -> Word128 -> Word128 +(*) = applyBiWordOnNatural (Prelude.*) + +-- | Division +quot :: Word128 -> Word128 -> Word128 +quot = applyBiWordOnNatural Prelude.quot + +-- | Modulo +rem :: Word128 -> Word128 -> Word128 +rem = applyBiWordOnNatural Prelude.rem + +-- | Bitwise and +bitwiseAnd :: Word128 -> Word128 -> Word128 +bitwiseAnd (Word128 a1 a0) (Word128 b1 b0) = + Word128 (a1 .&. b1) (a0 .&. b0) + +-- | Bitwise or +bitwiseOr :: Word128 -> Word128 -> Word128 +bitwiseOr (Word128 a1 a0) (Word128 b1 b0) = + Word128 (a1 .|. b1) (a0 .|. b0) + +-- | Bitwise xor +bitwiseXor :: Word128 -> Word128 -> Word128 +bitwiseXor (Word128 a1 a0) (Word128 b1 b0) = + Word128 (a1 `Bits.xor` b1) (a0 `Bits.xor` b0) + +-- | Bitwise complement +complement :: Word128 -> Word128 +complement (Word128 a1 a0) = Word128 (Bits.complement a1) (Bits.complement a0) + +-- | Population count +popCount :: Word128 -> Int +popCount (Word128 a1 a0) = Bits.popCount a1 Prelude.+ Bits.popCount a0 + +-- | Bitwise Shift Left +shiftL :: Word128 -> Int -> Word128 +shiftL w@(Word128 a1 a0) n + | n < 0 || n > 127 = Word128 0 0 + | n == 64 = Word128 a0 0 + | n == 0 = w + | n > 64 = Word128 (a0 `Bits.unsafeShiftL` (n Prelude.- 64)) 0 + | otherwise = Word128 ((a1 `Bits.unsafeShiftL` n) .|. (a0 `Bits.unsafeShiftR` (64 Prelude.- n))) + (a0 `Bits.unsafeShiftL` n) + +-- | Bitwise Shift Right +shiftR :: Word128 -> Int -> Word128 +shiftR w@(Word128 a1 a0) n + | n < 0 || n > 127 = Word128 0 0 + | n == 64 = Word128 0 a1 + | n == 0 = w + | n > 64 = Word128 0 (a1 `Bits.unsafeShiftR` (n Prelude.- 64)) + | otherwise = Word128 (a1 `Bits.unsafeShiftR` n) + ((a1 `Bits.unsafeShiftL` (inv64 n)) .|. (a0 `Bits.unsafeShiftR` n)) + +-- | Bitwise rotate Left +rotateL :: Word128 -> Int -> Word128 +rotateL (Word128 a1 a0) n' + | n == 0 = Word128 a1 a0 + | n == 64 = Word128 a0 a1 + | n < 64 = Word128 (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a1 (inv64 n)) + | otherwise = let nx = n Prelude.- 64 in Word128 (comb64 a0 nx a1 (inv64 nx)) (comb64 a1 n' a0 (inv64 nx)) + where + n :: Int + n | n' >= 0 = n' `Prelude.mod` 128 + | otherwise = 128 Prelude.- (n' `Prelude.mod` 128) + +-- | Bitwise rotate Left +rotateR :: Word128 -> Int -> Word128 +rotateR w n = rotateL w (128 Prelude.- n) + +inv64 :: Int -> Int +inv64 i = 64 Prelude.- i + +comb64 :: Word64 -> Int -> Word64 -> Int -> Word64 +comb64 x i y j = + (x `Bits.unsafeShiftL` i) .|. (y `Bits.unsafeShiftR` j) + +-- | Test bit +testBit :: Word128 -> Int -> Bool +testBit (Word128 a1 a0) n + | n < 0 || n > 127 = False + | n > 63 = Bits.testBit a1 (n Prelude.- 64) + | otherwise = Bits.testBit a0 n + +-- | bit +bit :: Int -> Word128 +bit n + | n < 0 || n > 127 = Word128 0 0 + | n > 63 = Word128 (Bits.bit (n Prelude.- 64)) 0 + | otherwise = Word128 0 (Bits.bit n) + +literal :: Integer -> Word128 +literal i = Word128 + (Prelude.fromInteger (i `Bits.unsafeShiftR` 64)) + (Prelude.fromInteger i) + +fromNatural :: Natural -> Word128 +fromNatural n = Word128 + (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 64)) + (Prelude.fromInteger $ naturalToInteger n) diff --git a/bundled/Basement/Types/Word256.hs b/bundled/Basement/Types/Word256.hs new file mode 100644 index 0000000..885ec0d --- /dev/null +++ b/bundled/Basement/Types/Word256.hs @@ -0,0 +1,351 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Basement.Types.Word256 + ( Word256(..) + , (+) + , (-) + , (*) + , quot + , rem + , bitwiseAnd + , bitwiseOr + , bitwiseXor + , complement + , shiftL + , shiftR + , rotateL + , rotateR + , popCount + , fromNatural + ) where + +import GHC.Prim hiding (word64ToWord#) +import qualified GHC.Prim +import GHC.Word +import GHC.Types +import qualified Prelude (fromInteger, show, Num(..), quot, rem, mod) +import Data.Bits hiding (complement, popCount, bit, testBit + , rotateL, rotateR, shiftL, shiftR) +import qualified Data.Bits as Bits +import Data.Function (on) +import Foreign.C +import Foreign.Ptr +import Foreign.Storable + +import Basement.Compat.Base +import Basement.Compat.Natural +import Basement.Compat.Primitive (bool#) +import Basement.Numerical.Conversion +import Basement.Numerical.Number + +#include "MachDeps.h" + +-- | 256 bits Word +data Word256 = Word256 {-# UNPACK #-} !Word64 + {-# UNPACK #-} !Word64 + {-# UNPACK #-} !Word64 + {-# UNPACK #-} !Word64 + deriving (Eq, Typeable) + +instance Show Word256 where + show w = Prelude.show (toNatural w) +instance Enum Word256 where + toEnum i = Word256 0 0 0 $ int64ToWord64 (intToInt64 i) + fromEnum (Word256 _ _ _ a0) = wordToInt (word64ToWord a0) + succ (Word256 a3 a2 a1 a0) + | a0 == maxBound = + if a1 == maxBound + then if a2 == maxBound + then Word256 (succ a3) 0 0 0 + else Word256 a3 (succ a2) 0 0 + else Word256 a3 a2 (succ a1) 0 + | otherwise = Word256 a3 a2 a1 (succ a0) + pred (Word256 a3 a2 a1 a0) + | a0 == minBound = + if a1 == minBound + then if a2 == minBound + then Word256 (pred a3) maxBound maxBound maxBound + else Word256 a3 (pred a2) maxBound maxBound + else Word256 a3 a2 (pred a1) maxBound + | otherwise = Word256 a3 a2 a1 (pred a0) +instance Bounded Word256 where + minBound = Word256 minBound minBound minBound minBound + maxBound = Word256 maxBound maxBound maxBound maxBound +instance Ord Word256 where + compare (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = + compareEq a3 b3 $ compareEq a2 b2 $ compareEq a1 b1 $ compare a0 b0 + where compareEq x y next = + case compare x y of + EQ -> next + r -> r + (<) (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = + compareLt a3 b3 $ compareLt a2 b2 $ compareLt a1 b1 (a0 < b0) + where compareLt x y next = + case compare x y of + EQ -> next + r -> r == LT +instance Storable Word256 where + sizeOf _ = 32 + alignment _ = 32 + peek p = Word256 <$> peek (castPtr p ) + <*> peek (castPtr p `plusPtr` 8) + <*> peek (castPtr p `plusPtr` 16) + <*> peek (castPtr p `plusPtr` 24) + poke p (Word256 a3 a2 a1 a0) = do + poke (castPtr p ) a3 + poke (castPtr p `plusPtr` 8 ) a2 + poke (castPtr p `plusPtr` 16) a1 + poke (castPtr p `plusPtr` 24) a0 + +instance Integral Word256 where + fromInteger = literal +instance HasNegation Word256 where + negate = complement + +instance IsIntegral Word256 where + toInteger (Word256 a3 a2 a1 a0) = + (toInteger a3 `Bits.unsafeShiftL` 192) Bits..|. + (toInteger a2 `Bits.unsafeShiftL` 128) Bits..|. + (toInteger a1 `Bits.unsafeShiftL` 64) Bits..|. + toInteger a0 +instance IsNatural Word256 where + toNatural (Word256 a3 a2 a1 a0) = + (toNatural a3 `Bits.unsafeShiftL` 192) Bits..|. + (toNatural a2 `Bits.unsafeShiftL` 128) Bits..|. + (toNatural a1 `Bits.unsafeShiftL` 64) Bits..|. + toNatural a0 + +instance Prelude.Num Word256 where + abs w = w + signum w@(Word256 a3 a2 a1 a0) + | a3 == 0 && a2 == 0 && a1 == 0 && a0 == 0 = w + | otherwise = Word256 0 0 0 1 + fromInteger = literal + (+) = (+) + (-) = (-) + (*) = (*) + +instance Bits.Bits Word256 where + (.&.) = bitwiseAnd + (.|.) = bitwiseOr + xor = bitwiseXor + complement = complement + shiftL = shiftL + shiftR = shiftR + rotateL = rotateL + rotateR = rotateR + bitSize _ = 256 + bitSizeMaybe _ = Just 256 + isSigned _ = False + testBit = testBit + bit = bit + popCount = popCount + +-- | Add 2 Word256 +(+) :: Word256 -> Word256 -> Word256 +#if WORD_SIZE_IN_BITS < 64 +(+) = applyBiWordOnNatural (Prelude.+) +#else +(+) (Word256 (W64# a3) (W64# a2) (W64# a1) (W64# a0)) + (Word256 (W64# b3) (W64# b2) (W64# b1) (W64# b0)) = +#if __GLASGOW_HASKELL__ >= 904 + Word256 (W64# (wordToWord64# s3)) (W64# (wordToWord64# s2)) (W64# (wordToWord64# s1)) (W64# (wordToWord64# s0)) + where + !(# c0, s0 #) = plusWord2# (GHC.Prim.word64ToWord# a0) (GHC.Prim.word64ToWord# b0) + !(# c1, s1 #) = plusWord3# (GHC.Prim.word64ToWord# a1) (GHC.Prim.word64ToWord# b1) (c0) + !(# c2, s2 #) = plusWord3# (GHC.Prim.word64ToWord# a2) (GHC.Prim.word64ToWord# b2) c1 + !s3 = plusWord3NoCarry# (GHC.Prim.word64ToWord# a3) (GHC.Prim.word64ToWord# b3) c2 + + plusWord3NoCarry# a b c = plusWord# (plusWord# a b) c + plusWord3# a b c + | bool# (eqWord# carry 0##) = plusWord2# x c + | otherwise = + case plusWord2# x c of + (# carry2, x' #) + | bool# (eqWord# carry2 0##) -> (# carry, x' #) + | otherwise -> (# plusWord# carry carry2, x' #) + where + (# carry, x #) = plusWord2# a b +#else + Word256 (W64# s3) (W64# s2) (W64# s1) (W64# s0) + where + !(# c0, s0 #) = plusWord2# a0 b0 + !(# c1, s1 #) = plusWord3# a1 b1 c0 + !(# c2, s2 #) = plusWord3# a2 b2 c1 + !s3 = plusWord3NoCarry# a3 b3 c2 + + plusWord3NoCarry# a b c = plusWord# (plusWord# a b) c + plusWord3# a b c + | bool# (eqWord# carry 0##) = plusWord2# x c + | otherwise = + case plusWord2# x c of + (# carry2, x' #) + | bool# (eqWord# carry2 0##) -> (# carry, x' #) + | otherwise -> (# plusWord# carry carry2, x' #) + where + (# carry, x #) = plusWord2# a b +#endif +#endif + +-- temporary available until native operation available +applyBiWordOnNatural :: (Natural -> Natural -> Natural) + -> Word256 + -> Word256 + -> Word256 +applyBiWordOnNatural f = (fromNatural .) . (f `on` toNatural) + +-- | Subtract 2 Word256 +(-) :: Word256 -> Word256 -> Word256 +(-) a b + | a >= b = applyBiWordOnNatural (Prelude.-) a b + | otherwise = complement (applyBiWordOnNatural (Prelude.-) b a) + 1 + +-- | Multiplication +(*) :: Word256 -> Word256 -> Word256 +(*) = applyBiWordOnNatural (Prelude.*) + +-- | Division +quot :: Word256 -> Word256 -> Word256 +quot = applyBiWordOnNatural Prelude.quot + +-- | Modulo +rem :: Word256 -> Word256 -> Word256 +rem = applyBiWordOnNatural Prelude.rem + +-- | Bitwise and +bitwiseAnd :: Word256 -> Word256 -> Word256 +bitwiseAnd (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = + Word256 (a3 Bits..&. b3) (a2 Bits..&. b2) (a1 Bits..&. b1) (a0 Bits..&. b0) + +-- | Bitwise or +bitwiseOr :: Word256 -> Word256 -> Word256 +bitwiseOr (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = + Word256 (a3 Bits..|. b3) (a2 Bits..|. b2) (a1 Bits..|. b1) (a0 Bits..|. b0) + +-- | Bitwise xor +bitwiseXor :: Word256 -> Word256 -> Word256 +bitwiseXor (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = + Word256 (a3 `Bits.xor` b3) (a2 `Bits.xor` b2) (a1 `Bits.xor` b1) (a0 `Bits.xor` b0) + +-- | Bitwise complement +complement :: Word256 -> Word256 +complement (Word256 a3 a2 a1 a0) = + Word256 (Bits.complement a3) (Bits.complement a2) (Bits.complement a1) (Bits.complement a0) + +-- | Population count +popCount :: Word256 -> Int +popCount (Word256 a3 a2 a1 a0) = + Bits.popCount a3 Prelude.+ + Bits.popCount a2 Prelude.+ + Bits.popCount a1 Prelude.+ + Bits.popCount a0 + +-- | Bitwise Shift Left +shiftL :: Word256 -> Int -> Word256 +shiftL w@(Word256 a3 a2 a1 a0) n + | n < 0 || n > 255 = Word256 0 0 0 0 + | n == 0 = w + | n == 64 = Word256 a2 a1 a0 0 + | n == 128 = Word256 a1 a0 0 0 + | n == 192 = Word256 a0 0 0 0 + | n < 64 = mkWordShift a3 a2 a1 a0 n + | n < 128 = mkWordShift a2 a1 a0 0 (n Prelude.- 64) + | n < 192 = mkWordShift a1 a0 0 0 (n Prelude.- 128) + | otherwise = mkWordShift a0 0 0 0 (n Prelude.- 192) + where + mkWordShift :: Word64 -> Word64 -> Word64 -> Word64 -> Int -> Word256 + mkWordShift w x y z s = + Word256 (comb64 w s x s') (comb64 x s y s') (comb64 y s z s') (z `Bits.unsafeShiftL` s) + where s' = inv64 s + +-- | Bitwise Shift Right +shiftR :: Word256 -> Int -> Word256 +shiftR w@(Word256 a3 a2 a1 a0) n + | n < 0 || n > 255 = Word256 0 0 0 0 + | n == 0 = w + | n == 64 = Word256 0 a3 a2 a1 + | n == 128 = Word256 0 0 a3 a2 + | n == 192 = Word256 0 0 0 a3 + | n < 64 = mkWordShift a3 a2 a1 a0 n + | n < 128 = mkWordShift 0 a3 a2 a1 (n Prelude.- 64) + | n < 192 = mkWordShift 0 0 a3 a2 (n Prelude.- 128) + | otherwise = Word256 0 0 0 (a3 `Bits.unsafeShiftR` (n Prelude.- 192)) + where + mkWordShift :: Word64 -> Word64 -> Word64 -> Word64 -> Int -> Word256 + mkWordShift w x y z s = + Word256 (w `Bits.unsafeShiftR` s) (comb64 w s' x s) (comb64 x s' y s) (comb64 y s' z s) + where s' = inv64 s + +-- | Bitwise rotate Left +rotateL :: Word256 -> Int -> Word256 +rotateL (Word256 a3 a2 a1 a0) n' + | n == 0 = Word256 a3 a2 a1 a0 + | n == 192 = Word256 a0 a3 a2 a1 + | n == 128 = Word256 a1 a0 a3 a2 + | n == 64 = Word256 a2 a1 a0 a3 + | n < 64 = Word256 (comb64 a3 n a2 (inv64 n)) (comb64 a2 n a1 (inv64 n)) + (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a3 (inv64 n)) + | n < 128 = let n = n Prelude.- 64 in Word256 + (comb64 a2 n a1 (inv64 n)) (comb64 a1 n a0 (inv64 n)) + (comb64 a0 n a3 (inv64 n)) (comb64 a3 n a2 (inv64 n)) + | n < 192 = let n = n Prelude.- 128 in Word256 + (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a3 (inv64 n)) + (comb64 a3 n a2 (inv64 n)) (comb64 a2 n a1 (inv64 n)) + | otherwise = let n = n Prelude.- 192 in Word256 + (comb64 a0 n a3 (inv64 n)) (comb64 a3 n a2 (inv64 n)) + (comb64 a2 n a1 (inv64 n)) (comb64 a1 n a0 (inv64 n)) + where + n :: Int + n | n' >= 0 = n' `Prelude.mod` 256 + | otherwise = 256 Prelude.- (n' `Prelude.mod` 256) + +-- | Bitwise rotate Left +rotateR :: Word256 -> Int -> Word256 +rotateR w n = rotateL w (256 Prelude.- n) + +inv64 :: Int -> Int +inv64 i = 64 Prelude.- i + +comb64 :: Word64 -> Int -> Word64 -> Int -> Word64 +comb64 x i y j = + (x `Bits.unsafeShiftL` i) .|. (y `Bits.unsafeShiftR` j) + +-- | Test bit +testBit :: Word256 -> Int -> Bool +testBit (Word256 a3 a2 a1 a0) n + | n < 0 || n > 255 = False + | n > 191 = Bits.testBit a3 (n Prelude.- 192) + | n > 127 = Bits.testBit a2 (n Prelude.- 128) + | n > 63 = Bits.testBit a1 (n Prelude.- 64) + | otherwise = Bits.testBit a0 n + +-- | bit +bit :: Int -> Word256 +bit n + | n < 0 || n > 255 = Word256 0 0 0 0 + | n > 191 = Word256 (Bits.bit (n Prelude.- 192)) 0 0 0 + | n > 127 = Word256 0 (Bits.bit (n Prelude.- 128)) 0 0 + | n > 63 = Word256 0 0 (Bits.bit (n Prelude.- 64)) 0 + | otherwise = Word256 0 0 0 (Bits.bit n) + +literal :: Integer -> Word256 +literal i = Word256 + (Prelude.fromInteger (i `Bits.unsafeShiftR` 192)) + (Prelude.fromInteger (i `Bits.unsafeShiftR` 128)) + (Prelude.fromInteger (i `Bits.unsafeShiftR` 64)) + (Prelude.fromInteger i) + +fromNatural :: Natural -> Word256 +fromNatural n = Word256 + (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 192)) + (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 128)) + (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 64)) + (Prelude.fromInteger $ naturalToInteger n) diff --git a/bundled/Basement/UArray.hs b/bundled/Basement/UArray.hs new file mode 100644 index 0000000..fa2e0a7 --- /dev/null +++ b/bundled/Basement/UArray.hs @@ -0,0 +1,947 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.UArray +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- An unboxed array of primitive types +-- +-- All the cells in the array are in one chunk of contiguous +-- memory. +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +module Basement.UArray + ( UArray(..) + , PrimType(..) + -- * methods + , copy + , unsafeCopyAtRO + -- * internal methods + -- , copyAddr + , recast + , unsafeRecast + , length + , freeze + , unsafeFreeze + , thaw + , unsafeThaw + -- * Creation + , vFromListN + , new + , create + , createFromIO + , createFromPtr + , sub + , copyToPtr + , withPtr + , withMutablePtr + , unsafeFreezeShrink + , freezeShrink + , fromBlock + , toBlock + -- * accessors + , update + , unsafeUpdate + , unsafeIndex + , unsafeIndexer + , unsafeDewrap + , unsafeRead + , unsafeWrite + -- * Functions + , equalMemcmp + , singleton + , replicate + , map + , mapIndex + , findIndex + , revFindIndex + , index + , null + , take + , unsafeTake + , drop + , unsafeDrop + , splitAt + , revDrop + , revTake + , revSplitAt + , splitOn + , break + , breakEnd + , breakElem + , breakLine + , elem + , indices + , intersperse + , span + , spanEnd + , cons + , snoc + , uncons + , unsnoc + , find + , sortBy + , filter + , reverse + , replace + , foldr + , foldl' + , foldr1 + , foldl1' + , all + , any + , isPrefixOf + , isSuffixOf + , foreignMem + , fromForeignPtr + , builderAppend + , builderBuild + , builderBuild_ + , toHexadecimal + , toBase64Internal + ) where + +import GHC.Prim +import GHC.Types +import GHC.Word +import GHC.ST +import GHC.Ptr +import GHC.ForeignPtr (ForeignPtr) +import Foreign.Marshal.Utils (copyBytes) +import Basement.Compat.Base +import Basement.Compat.Primitive +import Data.Proxy +import Basement.Types.OffsetSize +import Basement.Compat.MonadTrans +import Basement.NonEmpty +import Basement.Monad +import Basement.PrimType +import Basement.FinalPtr +import Basement.Exception +import Basement.UArray.Base +import Basement.Bits +import Basement.Block (Block(..), MutableBlock(..)) +import qualified Basement.Block as BLK +import qualified Basement.Block.Base as BLK (withPtr, unsafeWrite) +import Basement.UArray.Mutable hiding (sub, copyToPtr) +import Basement.Numerical.Additive +import Basement.Numerical.Subtractive +import Basement.Numerical.Multiplicative +import Basement.MutableBuilder +import Basement.Bindings.Memory (sysHsMemFindByteBa, sysHsMemFindByteAddr) +import qualified Basement.Compat.ExtList as List +import qualified Basement.Base16 as Base16 +import qualified Basement.Alg.Mutable as Alg +import qualified Basement.Alg.Class as Alg +import qualified Basement.Alg.PrimArray as Alg + +-- | Return the element at a specific index from an array. +-- +-- If the index @n is out of bounds, an error is raised. +index :: PrimType ty => UArray ty -> Offset ty -> ty +index array n + | isOutOfBound n len = outOfBound OOB_Index n len + | otherwise = unsafeIndex array n + where + !len = length array +{-# INLINE index #-} + +foreignMem :: PrimType ty + => FinalPtr ty -- ^ the start pointer with a finalizer + -> CountOf ty -- ^ the number of elements (in elements, not bytes) + -> UArray ty +foreignMem fptr nb = UArray (Offset 0) nb (UArrayAddr fptr) + +-- | Create a foreign UArray from foreign memory and given offset/size +-- +-- No check are performed to make sure this is valid, so this is unsafe. +-- +-- This is particularly useful when dealing with foreign memory and +-- 'ByteString' +fromForeignPtr :: PrimType ty + => (ForeignPtr ty, Int, Int) -- ForeignPtr, an offset in prim elements, a size in prim elements + -> UArray ty +fromForeignPtr (fptr, ofs, len) = UArray (Offset ofs) (CountOf len) (UArrayAddr $ toFinalPtrForeign fptr) + + +-- | Create a UArray from a Block +-- +-- The block is still used by the uarray +fromBlock :: PrimType ty + => Block ty + -> UArray ty +fromBlock blk = UArray 0 (BLK.length blk) (UArrayBA blk) + +-- | Allocate a new array with a fill function that has access to the elements of +-- the source array. +unsafeCopyFrom :: (PrimType a, PrimType b) + => UArray a -- ^ Source array + -> CountOf b -- ^ Length of the destination array + -> (UArray a -> Offset a -> MUArray b s -> ST s ()) + -- ^ Function called for each element in the source array + -> ST s (UArray b) -- ^ Returns the filled new array +unsafeCopyFrom v' newLen f = new newLen >>= fill 0 >>= unsafeFreeze + where len = length v' + fill i r' + | i .==# len = pure r' + | otherwise = do f v' i r' + fill (i + 1) r' + +-- | Freeze a MUArray into a UArray by copying all the content is a pristine new buffer +-- +-- The MUArray in parameter can be still be used after the call without +-- changing the resulting frozen data. +freeze :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> prim (UArray ty) +freeze ma = do + ma' <- new len + copyAt ma' (Offset 0) ma (Offset 0) len + unsafeFreeze ma' + where len = mutableLength ma + +-- | Just like 'freeze' but copy only the first n bytes +-- +-- The size requested need to be smaller or equal to the length +-- of the MUArray, otherwise a Out of Bounds exception is raised +freezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> CountOf ty -> prim (UArray ty) +freezeShrink ma n = do + when (n > mutableLength ma) $ primOutOfBound OOB_MemCopy (sizeAsOffset n) (mutableLength ma) + ma' <- new n + copyAt ma' (Offset 0) ma (Offset 0) n + unsafeFreeze ma' + +-- | Create a new array of size @n by settings each cells through the +-- function @f. +create :: forall ty . PrimType ty + => CountOf ty -- ^ the size of the array + -> (Offset ty -> ty) -- ^ the function that set the value at the index + -> UArray ty -- ^ the array created +create n initializer + | n == 0 = mempty + | otherwise = runST (new n >>= iter initializer) + where + iter :: (PrimType ty, PrimMonad prim) => (Offset ty -> ty) -> MUArray ty (PrimState prim) -> prim (UArray ty) + iter f ma = loop 0 + where + loop i + | i .==# n = unsafeFreeze ma + | otherwise = unsafeWrite ma i (f i) >> loop (i+1) + {-# INLINE loop #-} + {-# INLINE iter #-} + +-- | Create a pinned array that is filled by a 'filler' function (typically an IO call like hGetBuf) +createFromIO :: PrimType ty + => CountOf ty -- ^ the size of the array + -> (Ptr ty -> IO (CountOf ty)) -- ^ filling function that + -> IO (UArray ty) +createFromIO size filler + | size == 0 = pure mempty + | otherwise = do + mba <- newPinned size + r <- withMutablePtr mba $ \p -> filler p + case r of + 0 -> pure mempty -- make sure we don't keep our array referenced by using empty + _ | r < 0 -> error "filler returned negative number" + | otherwise -> unsafeFreezeShrink mba r + +-- | Freeze a chunk of memory pointed, of specific size into a new unboxed array +createFromPtr :: PrimType ty + => Ptr ty + -> CountOf ty + -> IO (UArray ty) +createFromPtr p s = do + ma <- new s + copyFromPtr p s ma + unsafeFreeze ma + +----------------------------------------------------------------------- +-- higher level collection implementation +----------------------------------------------------------------------- + +singleton :: PrimType ty => ty -> UArray ty +singleton ty = create 1 (const ty) + +replicate :: PrimType ty => CountOf ty -> ty -> UArray ty +replicate sz ty = create sz (const ty) + +-- | update an array by creating a new array with the updates. +-- +-- the operation copy the previous array, modify it in place, then freeze it. +update :: PrimType ty + => UArray ty + -> [(Offset ty, ty)] + -> UArray ty +update array modifiers = runST (thaw array >>= doUpdate modifiers) + where doUpdate l ma = loop l + where loop [] = unsafeFreeze ma + loop ((i,v):xs) = write ma i v >> loop xs + {-# INLINE loop #-} + {-# INLINE doUpdate #-} + +unsafeUpdate :: PrimType ty + => UArray ty + -> [(Offset ty, ty)] + -> UArray ty +unsafeUpdate array modifiers = runST (thaw array >>= doUpdate modifiers) + where doUpdate l ma = loop l + where loop [] = unsafeFreeze ma + loop ((i,v):xs) = unsafeWrite ma i v >> loop xs + {-# INLINE loop #-} + {-# INLINE doUpdate #-} + +-- | Copy all the block content to the memory starting at the destination address +copyToPtr :: forall ty prim . (PrimType ty, PrimMonad prim) + => UArray ty -- ^ the source array to copy + -> Ptr ty -- ^ The destination address where the copy is going to start + -> prim () +copyToPtr arr dst@(Ptr dst#) = onBackendPrim copyBa copyPtr arr + where + !(Offset os@(I# os#)) = offsetInBytes $ offset arr + !(CountOf szBytes@(I# szBytes#)) = sizeInBytes $ length arr + copyBa (Block ba) = primitive $ \s1 -> (# copyByteArrayToAddr# ba os# dst# szBytes# s1, () #) + copyPtr fptr = unsafePrimFromIO $ withFinalPtr fptr $ \ptr -> copyBytes dst (ptr `plusPtr` os) szBytes + +-- | Get a Ptr pointing to the data in the UArray. +-- +-- Since a UArray is immutable, this Ptr shouldn't be +-- to use to modify the contents +-- +-- If the UArray is pinned, then its address is returned as is, +-- however if it's unpinned, a pinned copy of the UArray is made +-- before getting the address. +withPtr :: forall ty prim a . (PrimMonad prim, PrimType ty) + => UArray ty + -> (Ptr ty -> prim a) + -> prim a +withPtr a f = + onBackendPrim (\blk -> BLK.withPtr blk $ \ptr -> f (ptr `plusPtr` os)) + (\fptr -> withFinalPtr fptr $ \ptr -> f (ptr `plusPtr` os)) + a + where + !sz = primSizeInBytes (Proxy :: Proxy ty) + !(Offset os) = offsetOfE sz $ offset a +{-# INLINE withPtr #-} + +-- | Recast an array of type a to an array of b +-- +-- a and b need to have the same size otherwise this +-- raise an async exception +recast :: forall a b . (PrimType a, PrimType b) => UArray a -> UArray b +recast array + | aTypeSize == bTypeSize = unsafeRecast array + | missing == 0 = unsafeRecast array + | otherwise = throw $ InvalidRecast + (RecastSourceSize alen) + (RecastDestinationSize $ alen + missing) + where + aTypeSize = primSizeInBytes (Proxy :: Proxy a) + bTypeSize@(CountOf bs) = primSizeInBytes (Proxy :: Proxy b) + (CountOf alen) = sizeInBytes (length array) + missing = alen `mod` bs + +-- | Unsafely recast an UArray containing 'a' to an UArray containing 'b' +-- +-- The offset and size are converted from units of 'a' to units of 'b', +-- but no check are performed to make sure this is compatible. +-- +-- use 'recast' if unsure. +unsafeRecast :: (PrimType a, PrimType b) => UArray a -> UArray b +unsafeRecast (UArray start len backend) = UArray (primOffsetRecast start) (sizeRecast len) $ + case backend of + UArrayAddr fptr -> UArrayAddr (castFinalPtr fptr) + UArrayBA (Block ba) -> UArrayBA (Block ba) +{-# INLINE [1] unsafeRecast #-} +{-# SPECIALIZE [3] unsafeRecast :: PrimType a => UArray Word8 -> UArray a #-} + +null :: UArray ty -> Bool +null arr = length arr == 0 + +-- | Take a count of elements from the array and create an array with just those elements +take :: CountOf ty -> UArray ty -> UArray ty +take n arr@(UArray start len backend) + | n <= 0 = empty + | n >= len = arr + | otherwise = UArray start n backend + +unsafeTake :: CountOf ty -> UArray ty -> UArray ty +unsafeTake sz (UArray start _ ba) = UArray start sz ba + +-- | Drop a count of elements from the array and return the new array minus those dropped elements +drop :: CountOf ty -> UArray ty -> UArray ty +drop n arr@(UArray start len backend) + | n <= 0 = arr + | Just newLen <- len - n, newLen > 0 = UArray (start `offsetPlusE` n) newLen backend + | otherwise = empty + +unsafeDrop :: CountOf ty -> UArray ty -> UArray ty +unsafeDrop n (UArray start sz backend) = UArray (start `offsetPlusE` n) (sz `sizeSub` n) backend + +-- | Split an array into two, with a count of at most N elements in the first one +-- and the remaining in the other. +splitAt :: CountOf ty -> UArray ty -> (UArray ty, UArray ty) +splitAt nbElems arr@(UArray start len backend) + | nbElems <= 0 = (empty, arr) + | Just nbTails <- len - nbElems, nbTails > 0 = (UArray start nbElems backend + ,UArray (start `offsetPlusE` nbElems) nbTails backend) + | otherwise = (arr, empty) + + +breakElem :: PrimType ty => ty -> UArray ty -> (UArray ty, UArray ty) +breakElem !ty arr@(UArray start len backend) + | k == sentinel = (arr, empty) + | k == start = (empty, arr) + | otherwise = (UArray start (offsetAsSize l1) backend + , UArray k (sizeAsOffset len - l1) backend) + where + !k = onBackendPure' arr $ Alg.findIndexElem ty + l1 = k `offsetSub` start +{-# NOINLINE [3] breakElem #-} +{-# RULES "breakElem Word8" [4] breakElem = breakElemByte #-} +{-# SPECIALIZE [3] breakElem :: Word32 -> UArray Word32 -> (UArray Word32, UArray Word32) #-} + +breakElemByte :: Word8 -> UArray Word8 -> (UArray Word8, UArray Word8) +breakElemByte !ty arr@(UArray start len backend) + | k == end = (arr, empty) + | k == start = (empty, arr) + | otherwise = ( UArray start (offsetAsSize k `sizeSub` offsetAsSize start) backend + , UArray k (len `sizeSub` (offsetAsSize k `sizeSub` offsetAsSize start)) backend) + where + !end = start `offsetPlusE` len + !k = onBackendPure goBa goAddr arr + goBa (Block ba) = sysHsMemFindByteBa ba start end ty + goAddr (Ptr addr) = sysHsMemFindByteAddr addr start end ty + +-- | Similar to breakElem specialized to split on linefeed +-- +-- it either returns: +-- * Left. no line has been found, and whether the last character is a CR +-- * Right, a line has been found with an optional CR, and it returns +-- the array of bytes on the left of the CR/LF, and the +-- the array of bytes on the right of the LF. +-- +breakLine :: UArray Word8 -> Either Bool (UArray Word8, UArray Word8) +breakLine arr@(UArray start len backend) + | end == start = Left False + | k2 == end = Left (k1 /= k2) + | otherwise = let newArray start' len' = if len' == 0 then empty else UArray start' len' backend + in Right (newArray start (k1-start), newArray (k2+1) (end - (k2+1))) + where + !end = start `offsetPlusE` len + -- return (offset of CR, offset of LF, whether the last element was a carriage return + !(k1, k2) = onBackendPure goBa goAddr arr + lineFeed = 0xa + carriageReturn = 0xd + goBa (Block ba) = + let k = sysHsMemFindByteBa ba start end lineFeed + cr = k > start && primBaIndex ba (k `offsetSub` 1) == carriageReturn + in (if cr then k `offsetSub` 1 else k, k) + goAddr (Ptr addr) = + let k = sysHsMemFindByteAddr addr start end lineFeed + cr = k > start && primAddrIndex addr (k `offsetSub` 1) == carriageReturn + in (if cr then k `offsetSub` 1 else k, k) + +-- inverse a CountOf that is specified from the end (e.g. take n elements from the end) +countFromStart :: UArray ty -> CountOf ty -> CountOf ty +countFromStart v sz@(CountOf sz') + | sz >= len = CountOf 0 + | otherwise = CountOf (len' - sz') + where len@(CountOf len') = length v + +-- | Take the N elements from the end of the array +revTake :: CountOf ty -> UArray ty -> UArray ty +revTake n v = drop (countFromStart v n) v + +-- | Drop the N elements from the end of the array +revDrop :: CountOf ty -> UArray ty -> UArray ty +revDrop n v = take (countFromStart v n) v + +-- | Split an array at the N element from the end, and return +-- the last N elements in the first part of the tuple, and whatever first +-- elements remaining in the second +revSplitAt :: CountOf ty -> UArray ty -> (UArray ty, UArray ty) +revSplitAt n v = (drop sz v, take sz v) where sz = countFromStart v n + +splitOn :: PrimType ty => (ty -> Bool) -> UArray ty -> [UArray ty] +splitOn xpredicate ivec + | len == 0 = [mempty] + | otherwise = runST $ unsafeIndexer ivec (pureST . go ivec xpredicate) + where + !len = length ivec + go v predicate getIdx = loop 0 0 + where + loop !prevIdx !idx + | idx .==# len = [sub v prevIdx idx] + | otherwise = + let e = getIdx idx + idx' = idx + 1 + in if predicate e + then sub v prevIdx idx : loop idx' idx' + else loop prevIdx idx' + {-# INLINE go #-} + +sub :: PrimType ty => UArray ty -> Offset ty -> Offset ty -> UArray ty +sub (UArray start len backend) startIdx expectedEndIdx + | startIdx >= endIdx = mempty + | otherwise = UArray (start + startIdx) newLen backend + where + newLen = endIdx - startIdx + endIdx = min expectedEndIdx (0 `offsetPlusE` len) + +findIndex :: PrimType ty => ty -> UArray ty -> Maybe (Offset ty) +findIndex ty arr + | k == sentinel = Nothing + | otherwise = Just (k `offsetSub` offset arr) + where + !k = onBackendPure' arr $ Alg.findIndexElem ty +{-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-} + +revFindIndex :: PrimType ty => ty -> UArray ty -> Maybe (Offset ty) +revFindIndex ty arr + | k == sentinel = Nothing + | otherwise = Just (k `offsetSub` offset arr) + where + !k = onBackendPure' arr $ Alg.revFindIndexElem ty +{-# SPECIALIZE [3] revFindIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-} + +break :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) +break predicate arr + | k == sentinel = (arr, mempty) + | otherwise = splitAt (k - offset arr) arr + where + !k = onBackendPure' arr $ Alg.findIndexPredicate predicate + +{- +{-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-} + | len == 0 = (mempty, mempty) + | otherwise = runST $ unsafeIndexer xv (go xv xpredicate) + where + !len = length xv + go :: PrimType ty => UArray ty -> (ty -> Bool) -> (Offset ty -> ty) -> ST s (UArray ty, UArray ty) + go v predicate getIdx = pure (findBreak $ Offset 0) + where + findBreak !i + | i .==# len = (v, mempty) + | predicate (getIdx i) = splitAt (offsetAsSize i) v + | otherwise = findBreak (i + Offset 1) + {-# INLINE findBreak #-} + {-# INLINE go #-} + -} +{-# NOINLINE [2] break #-} +{-# SPECIALIZE [2] break :: (Word8 -> Bool) -> UArray Word8 -> (UArray Word8, UArray Word8) #-} + +{- +{-# RULES "break (== ty)" [3] forall (x :: forall ty . PrimType ty => ty) . break (== x) = breakElem x #-} +{-# RULES "break (ty ==)" [3] forall (x :: forall ty . PrimType ty => ty) . break (x ==) = breakElem x #-} +{-# RULES "break (== ty)" [3] forall (x :: Word8) . break (== x) = breakElem x #-} +-} + +-- | Similar to break but start the search of the breakpoint from the end +-- +-- > breakEnd (> 0) [1,2,3,0,0,0] +-- ([1,2,3], [0,0,0]) +breakEnd :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) +breakEnd predicate arr + | k == sentinel = (arr, mempty) + | otherwise = splitAt ((k+1) - offset arr) arr + where + !k = onBackendPure' arr $ Alg.revFindIndexPredicate predicate +{-# SPECIALIZE [3] breakEnd :: (Word8 -> Bool) -> UArray Word8 -> (UArray Word8, UArray Word8) #-} + +elem :: PrimType ty => ty -> UArray ty -> Bool +elem !ty arr = onBackendPure' arr (Alg.findIndexElem ty) /= sentinel +{-# SPECIALIZE [2] elem :: Word8 -> UArray Word8 -> Bool #-} + +intersperse :: forall ty . PrimType ty => ty -> UArray ty -> UArray ty +intersperse sep v = case len - 1 of + Nothing -> v + Just 0 -> v + Just gaps -> runST $ unsafeCopyFrom v (len + gaps) go + where + len = length v + + go :: PrimType ty => UArray ty -> Offset ty -> MUArray ty s -> ST s () + go oldV oldI newV + | (oldI + 1) .==# len = unsafeWrite newV newI e + | otherwise = do + unsafeWrite newV newI e + unsafeWrite newV (newI + 1) sep + where + e = unsafeIndex oldV oldI + newI = scale (2 :: Word) oldI + +span :: PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) +span p = break (not . p) + +spanEnd :: PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) +spanEnd p = breakEnd (not . p) + +map :: (PrimType a, PrimType b) => (a -> b) -> UArray a -> UArray b +map f a = create lenB (\i -> f $ unsafeIndex a (offsetCast Proxy i)) + where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (length a) + +mapIndex :: (PrimType a, PrimType b) => (Offset b -> a -> b) -> UArray a -> UArray b +mapIndex f a = create (sizeCast Proxy $ length a) (\i -> f i $ unsafeIndex a (offsetCast Proxy i)) + +cons :: PrimType ty => ty -> UArray ty -> UArray ty +cons e vec + | len == CountOf 0 = singleton e + | otherwise = runST $ do + muv <- new (len + 1) + unsafeCopyAtRO muv 1 vec 0 len + unsafeWrite muv 0 e + unsafeFreeze muv + where + !len = length vec + +snoc :: PrimType ty => UArray ty -> ty -> UArray ty +snoc vec e + | len == CountOf 0 = singleton e + | otherwise = runST $ do + muv <- new (len + CountOf 1) + unsafeCopyAtRO muv (Offset 0) vec (Offset 0) len + unsafeWrite muv (0 `offsetPlusE` length vec) e + unsafeFreeze muv + where + !len = length vec + +uncons :: PrimType ty => UArray ty -> Maybe (ty, UArray ty) +uncons vec + | nbElems == 0 = Nothing + | otherwise = Just (unsafeIndex vec 0, sub vec 1 (0 `offsetPlusE` nbElems)) + where + !nbElems = length vec + +unsnoc :: PrimType ty => UArray ty -> Maybe (UArray ty, ty) +unsnoc vec = case length vec - 1 of + Nothing -> Nothing + Just newLen -> Just (sub vec 0 lastElem, unsafeIndex vec lastElem) + where !lastElem = 0 `offsetPlusE` newLen + +find :: PrimType ty => (ty -> Bool) -> UArray ty -> Maybe ty +find predicate vec = loop 0 + where + !len = length vec + loop i + | i .==# len = Nothing + | otherwise = + let e = unsafeIndex vec i + in if predicate e then Just e else loop (i+1) + +sortBy :: forall ty . PrimType ty => (ty -> ty -> Ordering) -> UArray ty -> UArray ty +sortBy ford vec = runST $ do + mvec <- thaw vec + onMutableBackend goNative (\fptr -> withFinalPtr fptr goAddr) mvec + unsafeFreeze mvec + where + !len = length vec + !start = offset vec + + goNative :: MutableBlock ty s -> ST s () + goNative mb = Alg.inplaceSortBy ford start len mb + goAddr :: Ptr ty -> ST s () + goAddr (Ptr addr) = Alg.inplaceSortBy ford start len (Ptr addr :: Ptr ty) +{-# SPECIALIZE [3] sortBy :: (Word8 -> Word8 -> Ordering) -> UArray Word8 -> UArray Word8 #-} + +filter :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> UArray ty +filter predicate arr = runST $ do + (newLen, ma) <- newNative (length arr) $ \(MutableBlock mba) -> + onBackendPrim (\block -> Alg.filter predicate mba block start end) + (\fptr -> withFinalPtr fptr $ \ptr@(Ptr !_) -> + Alg.filter predicate mba ptr start end) + arr + unsafeFreezeShrink ma newLen + where + !len = length arr + !start = offset arr + !end = start `offsetPlusE` len + +reverse :: forall ty . PrimType ty => UArray ty -> UArray ty +reverse a + | len == 0 = mempty + | otherwise = runST $ do + a <- newNative_ len $ \mba -> onBackendPrim (goNative mba) + (\fptr -> withFinalPtr fptr $ goAddr mba) + a + unsafeFreeze a + where + !len = length a + !end = 0 `offsetPlusE` len + !start = offset a + !endI = sizeAsOffset ((start + end) - Offset 1) + + goNative :: MutableBlock ty s -> Block ty -> ST s () + goNative !ma (Block !ba) = loop 0 + where + loop !i + | i == end = pure () + | otherwise = BLK.unsafeWrite ma i (primBaIndex ba (sizeAsOffset (endI - i))) >> loop (i+1) + goAddr :: MutableBlock ty s -> Ptr ty -> ST s () + goAddr !ma (Ptr addr) = loop 0 + where + loop !i + | i == end = pure () + | otherwise = BLK.unsafeWrite ma i (primAddrIndex addr (sizeAsOffset (endI - i))) >> loop (i+1) +{-# SPECIALIZE [3] reverse :: UArray Word8 -> UArray Word8 #-} +{-# SPECIALIZE [3] reverse :: UArray Word32 -> UArray Word32 #-} +{-# SPECIALIZE [3] reverse :: UArray Char -> UArray Char #-} + +-- Finds where are the insertion points when we search for a `needle` +-- within an `haystack`. +-- Throws an error in case `needle` is empty. +indices :: PrimType ty => UArray ty -> UArray ty -> [Offset ty] +indices needle hy + | needleLen <= 0 = error "Basement.UArray.indices: needle is empty." + | otherwise = case haystackLen < needleLen of + True -> [] + False -> go (Offset 0) [] + where + !haystackLen = length hy + + !needleLen = length needle + + go currentOffset ipoints + | (currentOffset `offsetPlusE` needleLen) > (sizeAsOffset haystackLen) = ipoints + | otherwise = + let matcher = take needleLen . drop (offsetAsSize currentOffset) $ hy + in case matcher == needle of + -- TODO: Move away from right-appending as it's gonna be slow. + True -> go (currentOffset `offsetPlusE` needleLen) (ipoints <> [currentOffset]) + False -> go (currentOffset + 1) ipoints + +-- | Replace all the occurrencies of `needle` with `replacement` in +-- the `haystack` string. +replace :: PrimType ty => UArray ty -> UArray ty -> UArray ty -> UArray ty +replace (needle :: UArray ty) replacement haystack = runST $ do + case null needle of + True -> error "Basement.UArray.replace: empty needle" + False -> do + let insertionPoints = indices needle haystack + let !(CountOf occs) = List.length insertionPoints + let !newLen = haystackLen `sizeSub` (multBy needleLen occs) + (multBy replacementLen occs) + ms <- new newLen + loop ms (Offset 0) (Offset 0) insertionPoints + where + + multBy (CountOf x) y = CountOf (x * y) + + !needleLen = length needle + + !replacementLen = length replacement + + !haystackLen = length haystack + + -- Go through each insertion point and copy things over. + -- We keep around the offset to the original string to + -- be able to copy bytes which didn't change. + loop :: PrimMonad prim + => MUArray ty (PrimState prim) + -> Offset ty + -> Offset ty + -> [Offset ty] + -> prim (UArray ty) + loop mba currentOffset offsetInOriginalString [] = do + -- Finalise the string + let !unchangedDataLen = sizeAsOffset haystackLen - offsetInOriginalString + unsafeCopyAtRO mba currentOffset haystack offsetInOriginalString unchangedDataLen + freeze mba + loop mba currentOffset offsetInOriginalString (x:xs) = do + -- 1. Copy from the old string. + let !unchangedDataLen = (x - offsetInOriginalString) + unsafeCopyAtRO mba currentOffset haystack offsetInOriginalString unchangedDataLen + let !newOffset = currentOffset `offsetPlusE` unchangedDataLen + -- 2. Copy the replacement. + unsafeCopyAtRO mba newOffset replacement (Offset 0) replacementLen + let !offsetInOriginalString' = offsetInOriginalString `offsetPlusE` unchangedDataLen `offsetPlusE` needleLen + loop mba (newOffset `offsetPlusE` replacementLen) offsetInOriginalString' xs +{-# SPECIALIZE [3] replace :: UArray Word8 -> UArray Word8 -> UArray Word8 -> UArray Word8 #-} + +foldr :: PrimType ty => (ty -> a -> a) -> a -> UArray ty -> a +foldr f initialAcc vec = loop 0 + where + !len = length vec + loop i + | i .==# len = initialAcc + | otherwise = unsafeIndex vec i `f` loop (i+1) + +foldl' :: PrimType ty => (a -> ty -> a) -> a -> UArray ty -> a +foldl' f initialAcc arr = onBackendPure' arr (Alg.foldl f initialAcc) +{-# SPECIALIZE [3] foldl' :: (a -> Word8 -> a) -> a -> UArray Word8 -> a #-} + +foldl1' :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (UArray ty) -> ty +foldl1' f (NonEmpty arr) = onBackendPure' arr (Alg.foldl1 f) +{-# SPECIALIZE [3] foldl1' :: (Word8 -> Word8 -> Word8) -> NonEmpty (UArray Word8) -> Word8 #-} + +foldr1 :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (UArray ty) -> ty +foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr + in foldr f (unsafeIndex initialAcc 0) rest + +all :: PrimType ty => (ty -> Bool) -> UArray ty -> Bool +all predicate arr = onBackendPure' arr $ Alg.all predicate +{-# SPECIALIZE [3] all :: (Word8 -> Bool) -> UArray Word8 -> Bool #-} + +any :: PrimType ty => (ty -> Bool) -> UArray ty -> Bool +any predicate arr = onBackendPure' arr $ Alg.any predicate +{-# SPECIALIZE [3] any :: (Word8 -> Bool) -> UArray Word8 -> Bool #-} + +builderAppend :: (PrimType ty, PrimMonad state) => ty -> Builder (UArray ty) (MUArray ty) ty state err () +builderAppend v = Builder $ State $ \(i, st, e) -> + if offsetAsSize i == chunkSize st + then do + cur <- unsafeFreeze (curChunk st) + newChunk <- new (chunkSize st) + unsafeWrite newChunk 0 v + pure ((), (Offset 1, st { prevChunks = cur : prevChunks st + , prevChunksSize = chunkSize st + prevChunksSize st + , curChunk = newChunk + }, e)) + else do + unsafeWrite (curChunk st) i v + pure ((), (i + 1, st, e)) + +builderBuild :: (PrimType ty, PrimMonad m) => Int -> Builder (UArray ty) (MUArray ty) ty m err () -> m (Either err (UArray ty)) +builderBuild sizeChunksI ab + | sizeChunksI <= 0 = builderBuild 64 ab + | otherwise = do + first <- new sizeChunks + (i, st, e) <- snd <$> runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks, Nothing) + case e of + Just err -> pure (Left err) + Nothing -> do + cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i) + -- Build final array + let totalSize = prevChunksSize st + offsetAsSize i + bytes <- new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze + pure (Right bytes) + where + sizeChunks = CountOf sizeChunksI + + fillFromEnd _ [] mua = pure mua + fillFromEnd !end (x:xs) mua = do + let sz = length x + let start = end `sizeSub` sz + unsafeCopyAtRO mua (sizeAsOffset start) x (Offset 0) sz + fillFromEnd start xs mua + +builderBuild_ :: (PrimType ty, PrimMonad m) => Int -> Builder (UArray ty) (MUArray ty) ty m () () -> m (UArray ty) +builderBuild_ sizeChunksI ab = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI ab + +toHexadecimal :: PrimType ty => UArray ty -> UArray Word8 +toHexadecimal ba + | len == CountOf 0 = mempty + | otherwise = runST $ do + ma <- new (len `scale` 2) + unsafeIndexer b8 (go ma) + unsafeFreeze ma + where + b8 = unsafeRecast ba + !len = length b8 + !endOfs = Offset 0 `offsetPlusE` len + + go :: MUArray Word8 s -> (Offset Word8 -> Word8) -> ST s () + go !ma !getAt = loop 0 0 + where + loop !dIdx !sIdx + | sIdx == endOfs = pure () + | otherwise = do + let !(W8# !w) = getAt sIdx + !(# wHi, wLo #) = Base16.unsafeConvertByte w + unsafeWrite ma dIdx (W8# wHi) + unsafeWrite ma (dIdx+1) (W8# wLo) + loop (dIdx + 2) (sIdx+1) + +toBase64Internal :: PrimType ty => Addr# -> UArray ty -> Bool -> UArray Word8 +toBase64Internal table src padded + | len == CountOf 0 = mempty + | otherwise = runST $ do + ma <- new dstLen + unsafeIndexer b8 (go ma) + unsafeFreeze ma + where + b8 = unsafeRecast src + !len = length b8 + !dstLen = outputLengthBase64 padded len + !endOfs = Offset 0 `offsetPlusE` len + !dstEndOfs = Offset 0 `offsetPlusE` dstLen + + go :: MUArray Word8 s -> (Offset Word8 -> Word8) -> ST s () + go !ma !getAt = loop 0 0 + where + eqChar = 0x3d :: Word8 + + loop !sIdx !dIdx + | sIdx == endOfs = when padded $ do + when (dIdx `offsetPlusE` CountOf 1 <= dstEndOfs) $ unsafeWrite ma dIdx eqChar + when (dIdx `offsetPlusE` CountOf 2 == dstEndOfs) $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 1) eqChar + | otherwise = do + let !b2Idx = sIdx `offsetPlusE` CountOf 1 + !b3Idx = sIdx `offsetPlusE` CountOf 2 + + !b2Available = b2Idx < endOfs + !b3Available = b3Idx < endOfs + + !b1 = getAt sIdx + !b2 = if b2Available then getAt b2Idx else 0 + !b3 = if b3Available then getAt b3Idx else 0 + + (w,x,y,z) = convert3 table b1 b2 b3 + + sNextIncr = 1 + fromEnum b2Available + fromEnum b3Available + dNextIncr = 1 + sNextIncr + + unsafeWrite ma dIdx w + unsafeWrite ma (dIdx `offsetPlusE` CountOf 1) x + + when b2Available $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 2) y + when b3Available $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 3) z + + loop (sIdx `offsetPlusE` CountOf sNextIncr) (dIdx `offsetPlusE` CountOf dNextIncr) + +outputLengthBase64 :: Bool -> CountOf Word8 -> CountOf Word8 +outputLengthBase64 padding (CountOf inputLenInt) = outputLength + where + outputLength = if padding then CountOf lenWithPadding else CountOf lenWithoutPadding + lenWithPadding + | m == 0 = 4 * d + | otherwise = 4 * (d + 1) + lenWithoutPadding + | m == 0 = 4 * d + | otherwise = 4 * d + m + 1 + (d,m) = inputLenInt `divMod` 3 + +convert3 :: Addr# -> Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8) +convert3 table a b c = + let !w = a .>>. 2 + !x = ((a .<<. 4) .&. 0x30) .|. (b .>>. 4) + !y = ((b .<<. 2) .&. 0x3c) .|. (c .>>. 6) + !z = c .&. 0x3f + in (idx w, idx x, idx y, idx z) + where + idx :: Word8 -> Word8 + idx (W8# i) = W8# (indexWord8OffAddr# table (word2Int# (word8ToWord# i))) + +isPrefixOf :: PrimType ty => UArray ty -> UArray ty -> Bool +isPrefixOf pre arr + | pLen > pArr = False + | otherwise = pre == unsafeTake pLen arr + where + !pLen = length pre + !pArr = length arr +{-# SPECIALIZE [3] isPrefixOf :: UArray Word8 -> UArray Word8 -> Bool #-} + +isSuffixOf :: PrimType ty => UArray ty -> UArray ty -> Bool +isSuffixOf suffix arr + | pLen > pArr = False + | otherwise = suffix == revTake pLen arr + where + !pLen = length suffix + !pArr = length arr +{-# SPECIALIZE [3] isSuffixOf :: UArray Word8 -> UArray Word8 -> Bool #-} diff --git a/bundled/Basement/UArray/Base.hs b/bundled/Basement/UArray/Base.hs new file mode 100644 index 0000000..e223906 --- /dev/null +++ b/bundled/Basement/UArray/Base.hs @@ -0,0 +1,655 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +module Basement.UArray.Base + ( MUArray(..) + , UArray(..) + , MUArrayBackend(..) + , UArrayBackend(..) + -- * New mutable array creation + , newUnpinned + , newPinned + , newNative + , newNative_ + , new + -- * Pinning status + , isPinned + , isMutablePinned + -- * Mutable array accessor + , unsafeRead + , unsafeWrite + -- * Freezing routines + , unsafeFreezeShrink + , unsafeFreeze + , unsafeThaw + , thaw + , copy + -- * Array accessor + , unsafeIndex + , unsafeIndexer + , onBackend + , onBackendPure + , onBackendPure' + , onBackendPrim + , onMutableBackend + , unsafeDewrap + , unsafeDewrap2 + -- * Basic lowlevel functions + , vFromListN + , empty + , length + , offset + , ValidRange(..) + , offsetsValidRange + , equal + , equalMemcmp + , compare + , copyAt + , unsafeCopyAtRO + , toBlock + -- * temporary + , pureST + ) where + +import GHC.Prim +import GHC.Types +import GHC.Ptr +import GHC.ST +import Basement.Compat.Primitive +import Basement.Monad +import Basement.PrimType +import Basement.Compat.Base +import Basement.Compat.C.Types +import Basement.Compat.Semigroup +import qualified Basement.Runtime as Runtime +import Data.Proxy +import qualified Basement.Compat.ExtList as List +import qualified Basement.Alg.Class as Alg +import Basement.Types.OffsetSize +import Basement.FinalPtr +import Basement.NormalForm +import Basement.Block (MutableBlock(..), Block(..)) +import qualified Basement.Block as BLK +import qualified Basement.Block.Mutable as MBLK +import Basement.Numerical.Additive +import Basement.Bindings.Memory +import System.IO.Unsafe (unsafeDupablePerformIO) + +-- | A Mutable array of types built on top of GHC primitive. +-- +-- Element in this array can be modified in place. +data MUArray ty st = MUArray {-# UNPACK #-} !(Offset ty) + {-# UNPACK #-} !(CountOf ty) + !(MUArrayBackend ty st) + +data MUArrayBackend ty st = MUArrayMBA (MutableBlock ty st) | MUArrayAddr (FinalPtr ty) + + +instance PrimType ty => Alg.Indexable (Ptr ty) ty where + index (Ptr addr) = primAddrIndex addr + +instance Alg.Indexable (Ptr Word8) Word64 where + index (Ptr addr) = primAddrIndex addr + +instance (PrimMonad prim, PrimType ty) => Alg.RandomAccess (Ptr ty) prim ty where + read (Ptr addr) = primAddrRead addr + write (Ptr addr) = primAddrWrite addr + +-- | An array of type built on top of GHC primitive. +-- +-- The elements need to have fixed sized and the representation is a +-- packed contiguous array in memory that can easily be passed +-- to foreign interface +data UArray ty = UArray {-# UNPACK #-} !(Offset ty) + {-# UNPACK #-} !(CountOf ty) + !(UArrayBackend ty) + deriving (Typeable) + +data UArrayBackend ty = UArrayBA !(Block ty) | UArrayAddr !(FinalPtr ty) + deriving (Typeable) + +instance Data ty => Data (UArray ty) where + dataTypeOf _ = arrayType + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + +arrayType :: DataType +arrayType = mkNoRepType "Basement.UArray" + +instance NormalForm (UArray ty) where + toNormalForm (UArray _ _ !_) = () +instance (PrimType ty, Show ty) => Show (UArray ty) where + show v = show (toList v) +instance (PrimType ty, Eq ty) => Eq (UArray ty) where + (==) = equal +instance (PrimType ty, Ord ty) => Ord (UArray ty) where + {-# SPECIALIZE instance Ord (UArray Word8) #-} + compare = vCompare + +instance PrimType ty => Semigroup (UArray ty) where + (<>) = append +instance PrimType ty => Monoid (UArray ty) where + mempty = empty + mconcat = concat + +instance PrimType ty => IsList (UArray ty) where + type Item (UArray ty) = ty + fromList = vFromList + fromListN len = vFromListN (CountOf len) + toList = vToList + +length :: UArray ty -> CountOf ty +length (UArray _ len _) = len +{-# INLINE[1] length #-} + +offset :: UArray ty -> Offset ty +offset (UArray ofs _ _) = ofs +{-# INLINE[1] offset #-} + +data ValidRange ty = ValidRange {-# UNPACK #-} !(Offset ty) {-# UNPACK #-} !(Offset ty) + +offsetsValidRange :: UArray ty -> ValidRange ty +offsetsValidRange (UArray ofs len _) = ValidRange ofs (ofs `offsetPlusE` len) + +-- | Return if the array is pinned in memory +-- +-- note that Foreign array are considered pinned +isPinned :: UArray ty -> PinnedStatus +isPinned (UArray _ _ (UArrayAddr {})) = Pinned +isPinned (UArray _ _ (UArrayBA blk)) = BLK.isPinned blk + +-- | Return if a mutable array is pinned in memory +isMutablePinned :: MUArray ty st -> PinnedStatus +isMutablePinned (MUArray _ _ (MUArrayAddr {})) = Pinned +isMutablePinned (MUArray _ _ (MUArrayMBA mb)) = BLK.isMutablePinned mb + +-- | Create a new pinned mutable array of size @n. +-- +-- all the cells are uninitialized and could contains invalid values. +-- +-- All mutable arrays are allocated on a 64 bits aligned addresses +newPinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim)) +newPinned n = MUArray 0 n . MUArrayMBA <$> MBLK.newPinned n + +-- | Create a new unpinned mutable array of size @n elements. +-- +-- If the size exceeds a GHC-defined threshold, then the memory will be +-- pinned. To be certain about pinning status with small size, use 'newPinned' +newUnpinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim)) +newUnpinned n = MUArray 0 n . MUArrayMBA <$> MBLK.new n + +newNative :: (PrimMonad prim, PrimType ty) + => CountOf ty + -> (MutableBlock ty (PrimState prim) -> prim a) + -> prim (a, MUArray ty (PrimState prim)) +newNative n f = do + mb <- MBLK.new n + a <- f mb + pure (a, MUArray 0 n (MUArrayMBA mb)) + +-- | Same as newNative but expect no extra return value from f +newNative_ :: (PrimMonad prim, PrimType ty) + => CountOf ty + -> (MutableBlock ty (PrimState prim) -> prim ()) + -> prim (MUArray ty (PrimState prim)) +newNative_ n f = do + mb <- MBLK.new n + f mb + pure (MUArray 0 n (MUArrayMBA mb)) + +-- | Create a new mutable array of size @n. +-- +-- When memory for a new array is allocated, we decide if that memory region +-- should be pinned (will not be copied around by GC) or unpinned (can be +-- moved around by GC) depending on its size. +-- +-- You can change the threshold value used by setting the environment variable +-- @HS_FOUNDATION_UARRAY_UNPINNED_MAX@. +new :: (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim)) +new sz + | sizeRecast sz <= maxSizeUnpinned = newUnpinned sz + | otherwise = newPinned sz + where + -- Safe to use here: If the value changes during runtime, this will only + -- have an impact on newly created arrays. + maxSizeUnpinned = Runtime.unsafeUArrayUnpinnedMaxSize +{-# INLINE new #-} + +-- | read from a cell in a mutable array without bounds checking. +-- +-- Reading from invalid memory can return unpredictable and invalid values. +-- use 'read' if unsure. +unsafeRead :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> prim ty +unsafeRead (MUArray start _ (MUArrayMBA (MutableBlock mba))) i = primMbaRead mba (start + i) +unsafeRead (MUArray start _ (MUArrayAddr fptr)) i = withFinalPtr fptr $ \(Ptr addr) -> primAddrRead addr (start + i) +{-# INLINE unsafeRead #-} + + +-- | write to a cell in a mutable array without bounds checking. +-- +-- Writing with invalid bounds will corrupt memory and your program will +-- become unreliable. use 'write' if unsure. +unsafeWrite :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> ty -> prim () +unsafeWrite (MUArray start _ (MUArrayMBA mb)) i v = MBLK.unsafeWrite mb (start+i) v +unsafeWrite (MUArray start _ (MUArrayAddr fptr)) i v = withFinalPtr fptr $ \(Ptr addr) -> primAddrWrite addr (start+i) v +{-# INLINE unsafeWrite #-} + +-- | Return the element at a specific index from an array without bounds checking. +-- +-- Reading from invalid memory can return unpredictable and invalid values. +-- use 'index' if unsure. +unsafeIndex :: forall ty . PrimType ty => UArray ty -> Offset ty -> ty +unsafeIndex (UArray start _ (UArrayBA ba)) n = BLK.unsafeIndex ba (start + n) +unsafeIndex (UArray start _ (UArrayAddr fptr)) n = withUnsafeFinalPtr fptr (\(Ptr addr) -> return (primAddrIndex addr (start+n)) :: IO ty) +{-# INLINE unsafeIndex #-} + +unsafeIndexer :: (PrimMonad prim, PrimType ty) => UArray ty -> ((Offset ty -> ty) -> prim a) -> prim a +unsafeIndexer (UArray start _ (UArrayBA ba)) f = f (\n -> BLK.unsafeIndex ba (start + n)) +unsafeIndexer (UArray start _ (UArrayAddr fptr)) f = withFinalPtr fptr $ \(Ptr addr) -> f (\n -> primAddrIndex addr (start + n)) +{-# INLINE unsafeIndexer #-} + +-- | Freeze a mutable array into an array. +-- +-- the MUArray must not be changed after freezing. +unsafeFreeze :: PrimMonad prim => MUArray ty (PrimState prim) -> prim (UArray ty) +unsafeFreeze (MUArray start len (MUArrayMBA mba)) = + UArray start len . UArrayBA <$> MBLK.unsafeFreeze mba +unsafeFreeze (MUArray start len (MUArrayAddr fptr)) = + pure $ UArray start len (UArrayAddr fptr) +{-# INLINE unsafeFreeze #-} + +unsafeFreezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> CountOf ty -> prim (UArray ty) +unsafeFreezeShrink (MUArray start _ backend) n = unsafeFreeze (MUArray start n backend) +{-# INLINE unsafeFreezeShrink #-} + +-- | Thaw an immutable array. +-- +-- The UArray must not be used after thawing. +unsafeThaw :: (PrimType ty, PrimMonad prim) => UArray ty -> prim (MUArray ty (PrimState prim)) +unsafeThaw (UArray start len (UArrayBA blk)) = MUArray start len . MUArrayMBA <$> BLK.unsafeThaw blk +unsafeThaw (UArray start len (UArrayAddr fptr)) = pure $ MUArray start len (MUArrayAddr fptr) +{-# INLINE unsafeThaw #-} + +-- | Thaw an array to a mutable array. +-- +-- the array is not modified, instead a new mutable array is created +-- and every values is copied, before returning the mutable array. +thaw :: (PrimMonad prim, PrimType ty) => UArray ty -> prim (MUArray ty (PrimState prim)) +thaw array = do + ma <- new (length array) + unsafeCopyAtRO ma azero array (Offset 0) (length array) + pure ma +{-# INLINE thaw #-} + +-- | Copy every cells of an existing array to a new array +copy :: PrimType ty => UArray ty -> UArray ty +copy array = runST (thaw array >>= unsafeFreeze) + + +onBackend :: (Block ty -> a) + -> (FinalPtr ty -> Ptr ty -> ST s a) + -> UArray ty + -> a +onBackend onBa _ (UArray _ _ (UArrayBA ba)) = onBa ba +onBackend _ onAddr (UArray _ _ (UArrayAddr fptr)) = withUnsafeFinalPtr fptr $ \ptr@(Ptr !_) -> + onAddr fptr ptr +{-# INLINE onBackend #-} + +onBackendPure :: (Block ty -> a) + -> (Ptr ty -> a) + -> UArray ty + -> a +onBackendPure goBA goAddr arr = onBackend goBA (\_ -> pureST . goAddr) arr +{-# INLINE onBackendPure #-} + +onBackendPure' :: forall ty a . PrimType ty + => UArray ty + -> (forall container. Alg.Indexable container ty + => container -> Offset ty -> Offset ty -> a) + -> a +onBackendPure' arr f = onBackendPure f' f' arr + where f' :: Alg.Indexable container ty => container -> a + f' c = f c start end + where (ValidRange !start !end) = offsetsValidRange arr +{-# INLINE onBackendPure' #-} + +onBackendPrim :: PrimMonad prim + => (Block ty -> prim a) + -> (FinalPtr ty -> prim a) + -> UArray ty + -> prim a +onBackendPrim onBa _ (UArray _ _ (UArrayBA ba)) = onBa ba +onBackendPrim _ onAddr (UArray _ _ (UArrayAddr fptr)) = onAddr fptr +{-# INLINE onBackendPrim #-} + +onMutableBackend :: PrimMonad prim + => (MutableBlock ty (PrimState prim) -> prim a) + -> (FinalPtr ty -> prim a) + -> MUArray ty (PrimState prim) + -> prim a +onMutableBackend onMba _ (MUArray _ _ (MUArrayMBA mba)) = onMba mba +onMutableBackend _ onAddr (MUArray _ _ (MUArrayAddr fptr)) = onAddr fptr +{-# INLINE onMutableBackend #-} + + +unsafeDewrap :: (Block ty -> Offset ty -> a) + -> (Ptr ty -> Offset ty -> ST s a) + -> UArray ty + -> a +unsafeDewrap _ g (UArray start _ (UArrayAddr fptr)) = withUnsafeFinalPtr fptr $ \ptr -> g ptr start +unsafeDewrap f _ (UArray start _ (UArrayBA ba)) = f ba start +{-# INLINE unsafeDewrap #-} + +unsafeDewrap2 :: (ByteArray# -> ByteArray# -> a) + -> (Ptr ty -> Ptr ty -> ST s a) + -> (ByteArray# -> Ptr ty -> ST s a) + -> (Ptr ty -> ByteArray# -> ST s a) + -> UArray ty + -> UArray ty + -> a +unsafeDewrap2 f g h i (UArray _ _ back1) (UArray _ _ back2) = + case (back1, back2) of + (UArrayBA (Block ba1), UArrayBA (Block ba2)) -> f ba1 ba2 + (UArrayAddr fptr1, UArrayAddr fptr2) -> withUnsafeFinalPtr fptr1 $ \ptr1 -> withFinalPtr fptr2 $ \ptr2 -> g ptr1 ptr2 + (UArrayBA (Block ba1), UArrayAddr fptr2) -> withUnsafeFinalPtr fptr2 $ \ptr2 -> h ba1 ptr2 + (UArrayAddr fptr1, UArrayBA (Block ba2)) -> withUnsafeFinalPtr fptr1 $ \ptr1 -> i ptr1 ba2 +{-# INLINE [2] unsafeDewrap2 #-} + +pureST :: a -> ST s a +pureST = pure + +-- | make an array from a list of elements. +vFromList :: forall ty . PrimType ty => [ty] -> UArray ty +vFromList l = runST $ do + a <- newNative_ len copyList + unsafeFreeze a + where + len = List.length l + copyList :: MutableBlock ty s -> ST s () + copyList mb = loop 0 l + where + loop _ [] = pure () + loop !i (x:xs) = MBLK.unsafeWrite mb i x >> loop (i+1) xs + +-- | Make an array from a list of elements with a size hint. +-- +-- The list should be of the same size as the hint, as otherwise: +-- +-- * The length of the list is smaller than the hint: +-- the array allocated is of the size of the hint, but is sliced +-- to only represent the valid bits +-- * The length of the list is bigger than the hint: +-- The allocated array is the size of the hint, and the list is truncated to +-- fit. +vFromListN :: forall ty . PrimType ty => CountOf ty -> [ty] -> UArray ty +vFromListN len l = runST $ do + (sz, ma) <- newNative len copyList + unsafeFreezeShrink ma sz + where + copyList :: MutableBlock ty s -> ST s (CountOf ty) + copyList mb = loop 0 l + where + loop !i [] = pure (offsetAsSize i) + loop !i (x:xs) + | i .==# len = pure (offsetAsSize i) + | otherwise = MBLK.unsafeWrite mb i x >> loop (i+1) xs + +-- | transform an array to a list. +vToList :: forall ty . PrimType ty => UArray ty -> [ty] +vToList a + | len == 0 = [] + | otherwise = unsafeDewrap goBa goPtr a + where + !len = length a + goBa (Block ba) start = loop start + where + !end = start `offsetPlusE` len + loop !i | i == end = [] + | otherwise = primBaIndex ba i : loop (i+1) + goPtr (Ptr addr) start = pureST (loop start) + where + !end = start `offsetPlusE` len + loop !i | i == end = [] + | otherwise = primAddrIndex addr i : loop (i+1) + +-- | Check if two vectors are identical +equal :: (PrimType ty, Eq ty) => UArray ty -> UArray ty -> Bool +equal a b + | la /= lb = False + | otherwise = unsafeDewrap2 goBaBa goPtrPtr goBaPtr goPtrBa a b + where + !start1 = offset a + !start2 = offset b + !end = start1 `offsetPlusE` la + !la = length a + !lb = length b + goBaBa ba1 ba2 = loop start1 start2 + where + loop !i !o | i == end = True + | otherwise = primBaIndex ba1 i == primBaIndex ba2 o && loop (i+o1) (o+o1) + goPtrPtr (Ptr addr1) (Ptr addr2) = pureST (loop start1 start2) + where + loop !i !o | i == end = True + | otherwise = primAddrIndex addr1 i == primAddrIndex addr2 o && loop (i+o1) (o+o1) + goBaPtr ba1 (Ptr addr2) = pureST (loop start1 start2) + where + loop !i !o | i == end = True + | otherwise = primBaIndex ba1 i == primAddrIndex addr2 o && loop (i+o1) (o+o1) + goPtrBa (Ptr addr1) ba2 = pureST (loop start1 start2) + where + loop !i !o | i == end = True + | otherwise = primAddrIndex addr1 i == primBaIndex ba2 o && loop (i+o1) (o+o1) + + o1 = Offset (I# 1#) +{-# RULES "UArray/Eq/Word8" [3] equal = equalBytes #-} +{-# INLINEABLE [2] equal #-} + +equalBytes :: UArray Word8 -> UArray Word8 -> Bool +equalBytes a b + | la /= lb = False + | otherwise = memcmp a b (sizeInBytes la) == 0 + where + !la = length a + !lb = length b + +equalMemcmp :: PrimType ty => UArray ty -> UArray ty -> Bool +equalMemcmp a b + | la /= lb = False + | otherwise = memcmp a b (sizeInBytes la) == 0 + where + !la = length a + !lb = length b + +-- | Compare 2 vectors +vCompare :: (Ord ty, PrimType ty) => UArray ty -> UArray ty -> Ordering +vCompare a@(UArray start1 la _) b@(UArray start2 lb _) = unsafeDewrap2 goBaBa goPtrPtr goBaPtr goPtrBa a b + where + !end = start1 `offsetPlusE` min la lb + o1 = Offset (I# 1#) + goBaBa ba1 ba2 = loop start1 start2 + where + loop !i !o | i == end = la `compare` lb + | v1 == v2 = loop (i + o1) (o + o1) + | otherwise = v1 `compare` v2 + where v1 = primBaIndex ba1 i + v2 = primBaIndex ba2 o + goPtrPtr (Ptr addr1) (Ptr addr2) = pureST (loop start1 start2) + where + loop !i !o | i == end = la `compare` lb + | v1 == v2 = loop (i + o1) (o + o1) + | otherwise = v1 `compare` v2 + where v1 = primAddrIndex addr1 i + v2 = primAddrIndex addr2 o + goBaPtr ba1 (Ptr addr2) = pureST (loop start1 start2) + where + loop !i !o | i == end = la `compare` lb + | v1 == v2 = loop (i + o1) (o + o1) + | otherwise = v1 `compare` v2 + where v1 = primBaIndex ba1 i + v2 = primAddrIndex addr2 o + goPtrBa (Ptr addr1) ba2 = pureST (loop start1 start2) + where + loop !i !o | i == end = la `compare` lb + | v1 == v2 = loop (i + o1) (o + o1) + | otherwise = v1 `compare` v2 + where v1 = primAddrIndex addr1 i + v2 = primBaIndex ba2 o +-- {-# SPECIALIZE [3] vCompare :: UArray Word8 -> UArray Word8 -> Ordering = vCompareBytes #-} +{-# RULES "UArray/Ord/Word8" [3] vCompare = vCompareBytes #-} +{-# INLINEABLE [2] vCompare #-} + +vCompareBytes :: UArray Word8 -> UArray Word8 -> Ordering +vCompareBytes = vCompareMemcmp + +vCompareMemcmp :: (Ord ty, PrimType ty) => UArray ty -> UArray ty -> Ordering +vCompareMemcmp a b = cintToOrdering $ memcmp a b sz + where + la = length a + lb = length b + sz = sizeInBytes $ min la lb + cintToOrdering :: CInt -> Ordering + cintToOrdering 0 = la `compare` lb + cintToOrdering r | r < 0 = LT + | otherwise = GT +{-# SPECIALIZE [3] vCompareMemcmp :: UArray Word8 -> UArray Word8 -> Ordering #-} + +memcmp :: PrimType ty => UArray ty -> UArray ty -> CountOf Word8 -> CInt +memcmp a@(UArray (offsetInBytes -> o1) _ _) b@(UArray (offsetInBytes -> o2) _ _) sz = unsafeDewrap2 + (\s1 s2 -> unsafeDupablePerformIO $ sysHsMemcmpBaBa s1 o1 s2 o2 sz) + (\s1 s2 -> unsafePrimToST $ sysHsMemcmpPtrPtr s1 o1 s2 o2 sz) + (\s1 s2 -> unsafePrimToST $ sysHsMemcmpBaPtr s1 o1 s2 o2 sz) + (\s1 s2 -> unsafePrimToST $ sysHsMemcmpPtrBa s1 o1 s2 o2 sz) + a b +{-# SPECIALIZE [3] memcmp :: UArray Word8 -> UArray Word8 -> CountOf Word8 -> CInt #-} + +-- | Copy a number of elements from an array to another array with offsets +copyAt :: forall prim ty . (PrimMonad prim, PrimType ty) + => MUArray ty (PrimState prim) -- ^ destination array + -> Offset ty -- ^ offset at destination + -> MUArray ty (PrimState prim) -- ^ source array + -> Offset ty -- ^ offset at source + -> CountOf ty -- ^ number of elements to copy + -> prim () +copyAt (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (MUArray srcStart _ (MUArrayMBA (MutableBlock srcBa))) es n = + primitive $ \st -> (# copyMutableByteArray# srcBa os dstMba od nBytes st, () #) + where + !sz = primSizeInBytes (Proxy :: Proxy ty) + !(Offset (I# os)) = offsetOfE sz (srcStart + es) + !(Offset (I# od)) = offsetOfE sz (dstStart + ed) + !(CountOf (I# nBytes)) = sizeOfE sz n +copyAt (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (MUArray srcStart _ (MUArrayAddr srcFptr)) es n = + withFinalPtr srcFptr $ \srcPtr -> + let !(Ptr srcAddr) = srcPtr `plusPtr` os + in primitive $ \s -> (# copyAddrToByteArray# srcAddr dstMba od nBytes s, () #) + where + !sz = primSizeInBytes (Proxy :: Proxy ty) + !(Offset os) = offsetOfE sz (srcStart + es) + !(Offset (I# od)) = offsetOfE sz (dstStart + ed) + !(CountOf (I# nBytes)) = sizeOfE sz n +copyAt dst od src os n = loop od os + where + !endIndex = os `offsetPlusE` n + loop !d !i + | i == endIndex = return () + | otherwise = unsafeRead src i >>= unsafeWrite dst d >> loop (d+1) (i+1) + +-- TODO Optimise with copyByteArray# +-- | Copy @n@ sequential elements from the specified offset in a source array +-- to the specified position in a destination array. +-- +-- This function does not check bounds. Accessing invalid memory can return +-- unpredictable and invalid values. +unsafeCopyAtRO :: forall prim ty . (PrimMonad prim, PrimType ty) + => MUArray ty (PrimState prim) -- ^ destination array + -> Offset ty -- ^ offset at destination + -> UArray ty -- ^ source array + -> Offset ty -- ^ offset at source + -> CountOf ty -- ^ number of elements to copy + -> prim () +unsafeCopyAtRO (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (UArray srcStart _ (UArrayBA (Block srcBa))) es n = + primitive $ \st -> (# copyByteArray# srcBa os dstMba od nBytes st, () #) + where + sz = primSizeInBytes (Proxy :: Proxy ty) + !(Offset (I# os)) = offsetOfE sz (srcStart+es) + !(Offset (I# od)) = offsetOfE sz (dstStart+ed) + !(CountOf (I# nBytes)) = sizeOfE sz n +unsafeCopyAtRO (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (UArray srcStart _ (UArrayAddr srcFptr)) es n = + withFinalPtr srcFptr $ \srcPtr -> + let !(Ptr srcAddr) = srcPtr `plusPtr` os + in primitive $ \s -> (# copyAddrToByteArray# srcAddr dstMba od nBytes s, () #) + where + sz = primSizeInBytes (Proxy :: Proxy ty) + !(Offset os) = offsetOfE sz (srcStart+es) + !(Offset (I# od)) = offsetOfE sz (dstStart+ed) + !(CountOf (I# nBytes)) = sizeOfE sz n +unsafeCopyAtRO dst od src os n = loop od os + where + !endIndex = os `offsetPlusE` n + loop d i + | i == endIndex = return () + | otherwise = unsafeWrite dst d (unsafeIndex src i) >> loop (d+1) (i+1) + +empty_ :: Block () +empty_ = runST $ primitive $ \s1 -> + case newByteArray# 0# s1 of { (# s2, mba #) -> + case unsafeFreezeByteArray# mba s2 of { (# s3, ba #) -> + (# s3, Block ba #) }} + +empty :: UArray ty +empty = UArray 0 0 (UArrayBA $ Block ba) where !(Block ba) = empty_ + +-- | Append 2 arrays together by creating a new bigger array +append :: PrimType ty => UArray ty -> UArray ty -> UArray ty +append a b + | la == azero = b + | lb == azero = a + | otherwise = runST $ do + r <- new (la+lb) + ma <- unsafeThaw a + mb <- unsafeThaw b + copyAt r (Offset 0) ma (Offset 0) la + copyAt r (sizeAsOffset la) mb (Offset 0) lb + unsafeFreeze r + where + !la = length a + !lb = length b + +concat :: forall ty . PrimType ty => [UArray ty] -> UArray ty +concat original = runST $ do + r <- new total + goCopy r 0 original + unsafeFreeze r + where + !total = size 0 original + -- size + size !sz [] = sz + size !sz (x:xs) = size (length x + sz) xs + + zero = Offset 0 + + goCopy r = loop + where + loop _ [] = pure () + loop !i (x:xs) = do + unsafeCopyAtRO r i x zero lx + loop (i `offsetPlusE` lx) xs + where !lx = length x + +-- | Create a Block from a UArray. +-- +-- Note that because of the slice, the destination block +-- is re-allocated and copied, unless the slice point +-- at the whole array +toBlock :: PrimType ty => UArray ty -> Block ty +toBlock arr@(UArray start len (UArrayBA blk)) + | start == 0 && BLK.length blk == len = blk + | otherwise = toBlock $ copy arr +toBlock arr = toBlock $ copy arr diff --git a/bundled/Basement/UArray/Mutable.hs b/bundled/Basement/UArray/Mutable.hs new file mode 100644 index 0000000..50e534c --- /dev/null +++ b/bundled/Basement/UArray/Mutable.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.UArray.Mutable -- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- A simple array abstraction that allow to use typed +-- array of bytes where the array is pinned in memory +-- to allow easy use with Foreign interfaces, ByteString +-- and always aligned to 64 bytes. +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Basement.UArray.Mutable + ( MUArray(..) + -- * Property queries + , sizeInMutableBytesOfContent + , mutableLength + , mutableOffset + , mutableSame + , onMutableBackend + -- * Allocation & Copy + , new + , newPinned + , newNative + , newNative_ + , mutableForeignMem + , copyAt + , copyFromPtr + , copyToPtr + , sub + -- , copyAddr + -- * Reading and Writing cells + , unsafeWrite + , unsafeRead + , write + , read + , withMutablePtr + , withMutablePtrHint + ) where + +import GHC.Prim +import GHC.Exts +import GHC.Types +import GHC.Ptr +import Basement.Compat.Base +import Basement.Compat.Primitive +import Data.Proxy +import Basement.Types.OffsetSize +import Basement.Monad +import Basement.PrimType +import Basement.FinalPtr +import Basement.Exception +import qualified Basement.Block as BLK +import qualified Basement.Block.Mutable as MBLK +import Basement.Block (MutableBlock(..)) +import Basement.UArray.Base hiding (empty) +import Basement.Numerical.Subtractive +import Foreign.Marshal.Utils (copyBytes) + +sizeInMutableBytesOfContent :: forall ty s . PrimType ty => MUArray ty s -> CountOf Word8 +sizeInMutableBytesOfContent _ = primSizeInBytes (Proxy :: Proxy ty) +{-# INLINE sizeInMutableBytesOfContent #-} + +-- | read a cell in a mutable array. +-- +-- If the index is out of bounds, an error is raised. +read :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> prim ty +read array n + | isOutOfBound n len = primOutOfBound OOB_Read n len + | otherwise = unsafeRead array n + where len = mutableLength array +{-# INLINE read #-} + +-- | Write to a cell in a mutable array. +-- +-- If the index is out of bounds, an error is raised. +write :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> ty -> prim () +write array n val + | isOutOfBound n len = primOutOfBound OOB_Write n len + | otherwise = unsafeWrite array n val + where + len = mutableLength array +{-# INLINE write #-} + +empty :: (PrimType ty, PrimMonad prim) => prim (MUArray ty (PrimState prim)) +empty = MUArray 0 0 . MUArrayMBA <$> MBLK.mutableEmpty + +mutableSame :: MUArray ty st -> MUArray ty st -> Bool +mutableSame (MUArray sa ea (MUArrayMBA (MutableBlock ma))) (MUArray sb eb (MUArrayMBA (MutableBlock mb))) = (sa == sb) && (ea == eb) && bool# (sameMutableByteArray# ma mb) +mutableSame (MUArray s1 e1 (MUArrayAddr f1)) (MUArray s2 e2 (MUArrayAddr f2)) = (s1 == s2) && (e1 == e2) && finalPtrSameMemory f1 f2 +mutableSame _ _ = False + +mutableForeignMem :: (PrimMonad prim, PrimType ty) + => FinalPtr ty -- ^ the start pointer with a finalizer + -> Int -- ^ the number of elements (in elements, not bytes) + -> prim (MUArray ty (PrimState prim)) +mutableForeignMem fptr nb = pure $ MUArray (Offset 0) (CountOf nb) (MUArrayAddr fptr) + +sub :: (PrimMonad prim, PrimType ty) + => MUArray ty (PrimState prim) + -> Int -- The number of elements to drop ahead + -> Int -- Then the number of element to retain + -> prim (MUArray ty (PrimState prim)) +sub (MUArray start sz back) dropElems' takeElems + | takeElems <= 0 = empty + | Just keepElems <- sz - dropElems, keepElems > 0 + = pure $ MUArray (start `offsetPlusE` dropElems) (min (CountOf takeElems) keepElems) back + | otherwise = empty + where + dropElems = max 0 (CountOf dropElems') + + +-- | return the numbers of elements in a mutable array +mutableLength :: PrimType ty => MUArray ty st -> CountOf ty +mutableLength (MUArray _ end _) = end + +withMutablePtrHint :: forall ty prim a . (PrimMonad prim, PrimType ty) + => Bool + -> Bool + -> MUArray ty (PrimState prim) + -> (Ptr ty -> prim a) + -> prim a +withMutablePtrHint skipCopy skipCopyBack (MUArray start _ back) f = + case back of + MUArrayAddr fptr -> withFinalPtr fptr (\ptr -> f (ptr `plusPtr` os)) + MUArrayMBA mb -> MBLK.withMutablePtrHint skipCopy skipCopyBack mb $ \ptr -> f (ptr `plusPtr` os) + where + sz = primSizeInBytes (Proxy :: Proxy ty) + !(Offset os) = offsetOfE sz start + +-- | Create a pointer on the beginning of the mutable array +-- and call a function 'f'. +-- +-- The mutable buffer can be mutated by the 'f' function +-- and the change will be reflected in the mutable array +-- +-- If the mutable array is unpinned, a trampoline buffer +-- is created and the data is only copied when 'f' return. +withMutablePtr :: (PrimMonad prim, PrimType ty) + => MUArray ty (PrimState prim) + -> (Ptr ty -> prim a) + -> prim a +withMutablePtr = withMutablePtrHint False False + +-- | Copy from a pointer, @count@ elements, into the mutable array +copyFromPtr :: forall prim ty . (PrimMonad prim, PrimType ty) + => Ptr ty -> CountOf ty -> MUArray ty (PrimState prim) -> prim () +copyFromPtr src@(Ptr src#) count marr + | count > arrSz = primOutOfBound OOB_MemCopy (sizeAsOffset count) arrSz + | otherwise = onMutableBackend copyNative copyPtr marr + where + arrSz = mutableLength marr + ofs = mutableOffset marr + + sz = primSizeInBytes (Proxy :: Proxy ty) + !count'@(CountOf bytes@(I# bytes#)) = sizeOfE sz count + !off'@(Offset od@(I# od#)) = offsetOfE sz ofs + + copyNative mba = MBLK.unsafeCopyBytesPtr mba off' src count' + copyPtr fptr = withFinalPtr fptr $ \dst -> + unsafePrimFromIO $ copyBytes (dst `plusPtr` od) src bytes + +-- | Copy all the block content to the memory starting at the destination address +copyToPtr :: forall ty prim . (PrimType ty, PrimMonad prim) + => MUArray ty (PrimState prim) -- ^ the source mutable array to copy + -> Ptr ty -- ^ The destination address where the copy is going to start + -> prim () +copyToPtr marr dst@(Ptr dst#) = onMutableBackend copyNative copyPtr marr + where + copyNative (MutableBlock mba) = primitive $ \s1 -> + case unsafeFreezeByteArray# mba s1 of + (# s2, ba #) -> (# copyByteArrayToAddr# ba os# dst# szBytes# s2, () #) + copyPtr fptr = unsafePrimFromIO $ withFinalPtr fptr $ \ptr -> + copyBytes dst (ptr `plusPtr` os) szBytes + + !(Offset os@(I# os#)) = offsetInBytes $ mutableOffset marr + !(CountOf szBytes@(I# szBytes#)) = sizeInBytes $ mutableLength marr + +mutableOffset :: MUArray ty st -> Offset ty +mutableOffset (MUArray ofs _ _) = ofs diff --git a/bundled/Basement/UTF8/Base.hs b/bundled/Basement/UTF8/Base.hs new file mode 100644 index 0000000..7fd05f4 --- /dev/null +++ b/bundled/Basement/UTF8/Base.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.String +-- License : BSD-style +-- Maintainer : Foundation +-- +-- A String type backed by a UTF8 encoded byte array and all the necessary +-- functions to manipulate the string. +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +module Basement.UTF8.Base + where + +import GHC.ST (ST, runST) +import GHC.Types +import GHC.Word +import GHC.Prim +import GHC.Exts (build) +import Basement.Compat.Base +import Basement.Numerical.Additive +import Basement.Compat.Bifunctor +import Basement.NormalForm +import Basement.Types.OffsetSize +import Basement.PrimType +import Basement.Monad +import Basement.FinalPtr +import Basement.UTF8.Helper +import Basement.UTF8.Types +import qualified Basement.Alg.UTF8 as UTF8 +import Basement.UArray (UArray) +import Basement.Block (MutableBlock) +import qualified Basement.Block.Mutable as BLK +import qualified Basement.UArray as Vec +import qualified Basement.UArray as C +import qualified Basement.UArray.Mutable as MVec +import Basement.UArray.Base as Vec (offset, pureST, onBackend, ValidRange(..), offsetsValidRange) +import GHC.CString (unpackCString#, unpackCStringUtf8#) + +import Data.Data +import Basement.Compat.ExtList as List +import Basement.Compat.Semigroup (Semigroup) + +-- | Opaque packed array of characters in the UTF8 encoding +newtype String = String (UArray Word8) + deriving (Typeable, Semigroup, Monoid, Eq, Ord) + +-- | Mutable String Buffer. +-- +-- Use as an *append* buffer, as UTF8 variable encoding +-- doesn't really allow to change previously written +-- character without potentially shifting bytes. +newtype MutableString st = MutableString (MVec.MUArray Word8 st) + deriving (Typeable) + +instance Show String where + show = show . sToList +instance IsString String where + fromString = sFromList +instance IsList String where + type Item String = Char + fromList = sFromList + toList = sToList + +instance Data String where + toConstr s = mkConstr stringType (show s) [] Prefix + dataTypeOf _ = stringType + gunfold _ _ = error "gunfold" + +instance NormalForm String where + toNormalForm (String ba) = toNormalForm ba + +stringType :: DataType +stringType = mkNoRepType "Foundation.String" + +-- | size in bytes. +-- +-- this size is available in o(1) +size :: String -> CountOf Word8 +size (String ba) = Vec.length ba + +-- | Convert a String to a list of characters +-- +-- The list is lazily created as evaluation needed +sToList :: String -> [Char] +sToList (String arr) = Vec.onBackend onBA onAddr arr + where + (Vec.ValidRange !start !end) = Vec.offsetsValidRange arr + onBA ba@(BLK.Block _) = loop start + where + loop !idx + | idx == end = [] + | otherwise = let !(Step c idx') = UTF8.next ba idx in c : loop idx' + onAddr fptr ptr@(Ptr _) = pureST (loop start) + where + loop !idx + | idx == end = [] + | otherwise = let !(Step c idx') = UTF8.next ptr idx in c : loop idx' +{-# NOINLINE sToList #-} + +sToListStream (String arr) k z = Vec.onBackend onBA onAddr arr + where + (Vec.ValidRange !start !end) = Vec.offsetsValidRange arr + onBA ba@(BLK.Block _) = loop start + where + loop !idx + | idx == end = z + | otherwise = let !(Step c idx') = UTF8.next ba idx in c `k` loop idx' + onAddr fptr ptr@(Ptr _) = pureST (loop start) + where + loop !idx + | idx == end = z + | otherwise = let !(Step c idx') = UTF8.next ptr idx in c `k` loop idx' + +{-# RULES "String sToList" [~1] forall s . sToList s = build (\ k z -> sToListStream s k z) #-} +{-# RULES "String toList" [~1] forall s . toList s = build (\ k z -> sToListStream s k z) #-} + +{-# RULES "String sFromList" forall s . sFromList (unpackCString# s) = fromModified s #-} +{-# RULES "String sFromList" forall s . sFromList (unpackCStringUtf8# s) = fromModified s #-} + +-- | assuming the given Addr# is a valid modified UTF-8 sequence of bytes +-- +-- We only modify the given Unicode Null-character (0xC080) into a null bytes +-- +-- FIXME: need to evaluate the kind of modified UTF8 GHC is actually expecting +-- it is plausible they only handle the Null Bytes, which this function actually +-- does. +fromModified :: Addr# -> String +fromModified addr = countAndCopy 0 0 + where + countAndCopy :: CountOf Word8 -> Offset Word8 -> String + countAndCopy count ofs = + case primAddrIndex addr ofs of + 0x00 -> runST $ do + mb <- MVec.newNative_ count (copy count) + String <$> Vec.unsafeFreeze mb + 0xC0 -> case primAddrIndex addr (ofs+1) of + 0x80 -> countAndCopy (count+1) (ofs+2) + _ -> countAndCopy (count+2) (ofs+2) + _ -> countAndCopy (count+1) (ofs+1) + + copy :: CountOf Word8 -> MutableBlock Word8 st -> ST st () + copy count mba = loop 0 0 + where loop o i + | o .==# count = pure () + | otherwise = + case primAddrIndex addr i of + 0xC0 -> case primAddrIndex addr (i+1) of + 0x80 -> BLK.unsafeWrite mba o 0x00 >> loop (o+1) (i+2) + b2 -> BLK.unsafeWrite mba o 0xC0 >> BLK.unsafeWrite mba (o+1) b2 >> loop (o+2) (i+2) + b1 -> BLK.unsafeWrite mba o b1 >> loop (o+1) (i+1) + + +-- | Create a new String from a list of characters +-- +-- The list is strictly and fully evaluated before +-- creating the new String, as the size need to be +-- computed before filling. +sFromList :: [Char] -> String +sFromList l = runST (new bytes >>= startCopy) + where + -- count how many bytes + !bytes = List.sum $ fmap (charToBytes . fromEnum) l + + startCopy :: MutableString (PrimState (ST st)) -> ST st String + startCopy ms = loop 0 l + where + loop _ [] = freeze ms + loop idx (c:xs) = write ms idx c >>= \idx' -> loop idx' xs +{-# INLINE [0] sFromList #-} + +next :: String -> Offset8 -> Step +next (String array) !n = Vec.onBackend nextBA nextAddr array + where + !start = Vec.offset array + reoffset (Step a ofs) = Step a (ofs `offsetSub` start) + nextBA ba@(BLK.Block _) = reoffset (UTF8.next ba (start + n)) + nextAddr _ ptr@(Ptr _) = pureST $ reoffset (UTF8.next ptr (start + n)) + +prev :: String -> Offset8 -> StepBack +prev (String array) !n = Vec.onBackend prevBA prevAddr array + where + !start = Vec.offset array + reoffset (StepBack a ofs) = StepBack a (ofs `offsetSub` start) + prevBA ba@(BLK.Block _) = reoffset (UTF8.prev ba (start + n)) + prevAddr _ ptr@(Ptr _) = pureST $ reoffset (UTF8.prev ptr (start + n)) + +-- A variant of 'next' when you want the next character +-- to be ASCII only. +nextAscii :: String -> Offset8 -> StepASCII +nextAscii (String ba) n = StepASCII w + where + !w = Vec.unsafeIndex ba n + +expectAscii :: String -> Offset8 -> Word8 -> Bool +expectAscii (String ba) n v = Vec.unsafeIndex ba n == v +{-# INLINE expectAscii #-} + +write :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Char -> prim Offset8 +write (MutableString marray) ofs c = + MVec.onMutableBackend (\mba@(BLK.MutableBlock _) -> UTF8.writeUTF8 mba (start + ofs) c) + (\fptr -> withFinalPtr fptr $ \ptr@(Ptr _) -> UTF8.writeUTF8 ptr (start + ofs) c) + marray + where start = MVec.mutableOffset marray + +-- | Allocate a MutableString of a specific size in bytes. +new :: PrimMonad prim + => CountOf Word8 -- ^ in number of bytes, not of elements. + -> prim (MutableString (PrimState prim)) +new n = MutableString `fmap` MVec.new n + +newNative :: PrimMonad prim + => CountOf Word8 -- ^ in number of bytes, not of elements. + -> (MutableBlock Word8 (PrimState prim) -> prim a) + -> prim (a, MutableString (PrimState prim)) +newNative n f = second MutableString `fmap` MVec.newNative n f + +newNative_ :: PrimMonad prim + => CountOf Word8 -- ^ in number of bytes, not of elements. + -> (MutableBlock Word8 (PrimState prim) -> prim ()) + -> prim (MutableString (PrimState prim)) +newNative_ n f = MutableString `fmap` MVec.newNative_ n f + +freeze :: PrimMonad prim => MutableString (PrimState prim) -> prim String +freeze (MutableString mba) = String `fmap` C.unsafeFreeze mba +{-# INLINE freeze #-} + +freezeShrink :: PrimMonad prim + => CountOf Word8 + -> MutableString (PrimState prim) + -> prim String +freezeShrink n (MutableString mba) = String `fmap` C.unsafeFreezeShrink mba n diff --git a/bundled/Basement/UTF8/Helper.hs b/bundled/Basement/UTF8/Helper.hs new file mode 100644 index 0000000..82b0cad --- /dev/null +++ b/bundled/Basement/UTF8/Helper.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.UTF8.Helper +-- License : BSD-style +-- Maintainer : Foundation +-- +-- Some low level helpers to use UTF8 +-- +-- Most helpers are lowlevel and unsafe, don't use +-- directly. +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +module Basement.UTF8.Helper + where + +import Basement.Compat.Base +import Basement.Compat.Primitive +import Basement.Types.OffsetSize +import Basement.UTF8.Types +import Basement.Bits +import GHC.Prim +import GHC.Types +import GHC.Word + +-- mask an UTF8 continuation byte (stripping the leading 10 and returning 6 valid bits) +maskContinuation# :: Word# -> Word# +maskContinuation# v = and# v 0x3f## +{-# INLINE maskContinuation# #-} + +-- mask a UTF8 header for 2 bytes encoding (110xxxxx and 5 valid bits) +maskHeader2# :: Word# -> Word# +maskHeader2# h = and# h 0x1f## +{-# INLINE maskHeader2# #-} + +-- mask a UTF8 header for 3 bytes encoding (1110xxxx and 4 valid bits) +maskHeader3# :: Word# -> Word# +maskHeader3# h = and# h 0xf## +{-# INLINE maskHeader3# #-} + +-- mask a UTF8 header for 4 bytes encoding (11110xxx and 3 valid bits) +maskHeader4# :: Word# -> Word# +maskHeader4# h = and# h 0x7## +{-# INLINE maskHeader4# #-} + +or3# :: Word# -> Word# -> Word# -> Word# +or3# a b c = or# a (or# b c) +{-# INLINE or3# #-} + +or4# :: Word# -> Word# -> Word# -> Word# -> Word# +or4# a b c d = or# (or# a b) (or# c d) +{-# INLINE or4# #-} + +toChar# :: Word# -> Char +toChar# w = C# (chr# (word2Int# w)) +{-# INLINE toChar# #-} + +toChar1 :: StepASCII -> Char +toChar1 (StepASCII (W8# w)) = C# (word8ToChar# w) + +toChar2 :: StepASCII -> Word8 -> Char +toChar2 (StepASCII (W8# b1)) (W8# b2) = + toChar# (or# (uncheckedShiftL# (maskHeader2# w1) 6#) (maskContinuation# w2)) + where + w1 = word8ToWord# b1 + w2 = word8ToWord# b2 + +toChar3 :: StepASCII -> Word8 -> Word8 -> Char +toChar3 (StepASCII (W8# b1)) (W8# b2) (W8# b3) = + toChar# (or3# (uncheckedShiftL# (maskHeader3# w1) 12#) + (uncheckedShiftL# (maskContinuation# w2) 6#) + (maskContinuation# w3) + ) + where + w1 = word8ToWord# b1 + w2 = word8ToWord# b2 + w3 = word8ToWord# b3 + +toChar4 :: StepASCII -> Word8 -> Word8 -> Word8 -> Char +toChar4 (StepASCII (W8# b1)) (W8# b2) (W8# b3) (W8# b4) = + toChar# (or4# (uncheckedShiftL# (maskHeader4# w1) 18#) + (uncheckedShiftL# (maskContinuation# w2) 12#) + (uncheckedShiftL# (maskContinuation# w3) 6#) + (maskContinuation# w4) + ) + where + w1 = word8ToWord# b1 + w2 = word8ToWord# b2 + w3 = word8ToWord# b3 + w4 = word8ToWord# b4 + +-- | Different way to encode a Character in UTF8 represented as an ADT +data UTF8Char = + UTF8_1 {-# UNPACK #-} !Word8 + | UTF8_2 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 + | UTF8_3 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 + | UTF8_4 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 + +-- | Transform a Unicode code point 'Char' into +-- +-- note that we expect here a valid unicode code point in the *allowed* range. +-- bits will be lost if going above 0x10ffff +asUTF8Char :: Char -> UTF8Char +asUTF8Char !(C# c) + | bool# (ltWord# x 0x80## ) = encode1 + | bool# (ltWord# x 0x800## ) = encode2 + | bool# (ltWord# x 0x10000##) = encode3 + | otherwise = encode4 + where + !x = int2Word# (ord# c) + + encode1 = UTF8_1 (W8# (wordToWord8# x)) + encode2 = + let !x1 = W8# (wordToWord8# (or# (uncheckedShiftRL# x 6#) 0xc0##)) + !x2 = toContinuation x + in UTF8_2 x1 x2 + encode3 = + let !x1 = W8# (wordToWord8# (or# (uncheckedShiftRL# x 12#) 0xe0##)) + !x2 = toContinuation (uncheckedShiftRL# x 6#) + !x3 = toContinuation x + in UTF8_3 x1 x2 x3 + encode4 = + let !x1 = W8# (wordToWord8# (or# (uncheckedShiftRL# x 18#) 0xf0##)) + !x2 = toContinuation (uncheckedShiftRL# x 12#) + !x3 = toContinuation (uncheckedShiftRL# x 6#) + !x4 = toContinuation x + in UTF8_4 x1 x2 x3 x4 + + toContinuation :: Word# -> Word8 + toContinuation w = W8# (wordToWord8# (or# (and# w 0x3f##) 0x80##)) + {-# INLINE toContinuation #-} + +-- given the encoding of UTF8 Char, get the number of bytes of this sequence +numBytes :: UTF8Char -> CountOf Word8 +numBytes UTF8_1{} = CountOf 1 +numBytes UTF8_2{} = CountOf 2 +numBytes UTF8_3{} = CountOf 3 +numBytes UTF8_4{} = CountOf 4 + +-- given the leading byte of a utf8 sequence, get the number of bytes of this sequence +skipNextHeaderValue :: Word8 -> CountOf Word8 +skipNextHeaderValue !x + | x < 0xC0 = CountOf 1 -- 0b11000000 + | x < 0xE0 = CountOf 2 -- 0b11100000 + | x < 0xF0 = CountOf 3 -- 0b11110000 + | otherwise = CountOf 4 +{-# INLINE skipNextHeaderValue #-} + +headerIsAscii :: StepASCII -> Bool +headerIsAscii (StepASCII x) = x < 0x80 + +charToBytes :: Int -> CountOf Word8 +charToBytes c + | c < 0x80 = CountOf 1 + | c < 0x800 = CountOf 2 + | c < 0x10000 = CountOf 3 + | c < 0x110000 = CountOf 4 + | otherwise = error ("invalid code point: " `mappend` show c) + +-- | Encode a Char into a CharUTF8 +encodeCharUTF8 :: Char -> CharUTF8 +encodeCharUTF8 !(C# c) + | bool# (ltWord# x 0x80## ) = CharUTF8 (W32# (wordToWord32# x)) + | bool# (ltWord# x 0x800## ) = CharUTF8 (W32# (wordToWord32# encode2)) + | bool# (ltWord# x 0x10000##) = CharUTF8 (W32# (wordToWord32# encode3)) + | otherwise = CharUTF8 (W32# (wordToWord32# encode4)) + where + !x = int2Word# (ord# c) + + -- clearing mask, clearing all the bits that need to be clear as per the UTF8 encoding + mask2 = 0x0000bfdf## -- 1 continuation , 5 bits header + mask3 = 0x00bfbfef## -- 2 continuations, 4 bits header + mask4 = 0xbfbfbff7## -- 3 continuations, 3 bits header + + -- setting mask, settings all the bits that need to be set per the UTF8 encoding + set2 = 0x000080c0## -- 10xxxxxx 110xxxxx + set3 = 0x008080e0## -- 10xxxxxx * 2 1110xxxx + set4 = 0x808080f0## -- 10xxxxxx * 3 11111xxx + + encode2 = and# mask2 (or3# set2 + (uncheckedShiftRL# x 6#) -- 5 bits to 1st byte + (uncheckedShiftL# x 8# ) -- move lowest bits to the 2nd byte + ) + encode3 = and# mask3 (or4# set3 + (uncheckedShiftRL# x 12#) -- 4 bits to 1st byte + (and# 0x3f00## (uncheckedShiftL# x 2#)) -- 6 bits to the 2nd byte + (uncheckedShiftL# x 16# ) -- move lowest bits to the 3rd byte + ) + encode4 = and# mask4 (or4# set4 + (uncheckedShiftRL# x 18#) -- 3 bits to 1st byte + (or# (and# 0x3f00## (uncheckedShiftRL# x 4#)) -- 6 bits to the 2nd byte + (and# 0x3f0000## (uncheckedShiftL# x 10#)) -- 6 bits to the 3nd byte + ) + (uncheckedShiftL# x 24# ) -- move lowest bits to the 4rd byte + ) + +-- | decode a CharUTF8 into a Char +-- +-- If the value inside a CharUTF8 is not properly encoded, this will result in violation +-- of the Char invariants +decodeCharUTF8 :: CharUTF8 -> Char +decodeCharUTF8 c@(CharUTF8 !(W32# w_)) + | isCharUTF8Case1 c = toChar# w + | isCharUTF8Case2 c = encode2 + | isCharUTF8Case3 c = encode3 + | otherwise = encode4 + where + w = word32ToWord# w_ + encode2 = + toChar# (or# (uncheckedShiftL# (maskHeader2# w) 6#) + (maskContinuation# (uncheckedShiftRL# w 8#)) + ) + encode3 = + toChar# (or3# (uncheckedShiftL# (maskHeader3# w) 12#) + (uncheckedShiftRL# (and# 0x3f00## w) 8#) + (maskContinuation# (uncheckedShiftRL# w 16#)) + ) + encode4 = + toChar# (or4# (uncheckedShiftL# (maskHeader4# w) 18#) + (uncheckedShiftRL# (and# 0x3f00## w) 10#) + (uncheckedShiftL# (and# 0x3f0000## w) 4#) + (maskContinuation# (uncheckedShiftRL# w 24#)) + ) + + -- clearing mask, removing all UTF8 metadata and keeping only signal (content) + --maskContent2 = 0x00003f1f## -- 1 continuation , 5 bits header + --maskContent3 = 0x003f3f0f## -- 2 continuations, 4 bits header + --maskContent4 = 0x3f3f3f07## -- 3 continuations, 3 bits header + +isCharUTF8Case1 :: CharUTF8 -> Bool +isCharUTF8Case1 (CharUTF8 !w) = (w .&. 0x80) == 0 +{-# INLINE isCharUTF8Case1 #-} + +isCharUTF8Case2 :: CharUTF8 -> Bool +isCharUTF8Case2 (CharUTF8 !w) = (w .&. 0x20) == 0 +{-# INLINE isCharUTF8Case2 #-} + +isCharUTF8Case3 :: CharUTF8 -> Bool +isCharUTF8Case3 (CharUTF8 !w) = (w .&. 0x10) == 0 +{-# INLINE isCharUTF8Case3 #-} + +isCharUTF8Case4 :: CharUTF8 -> Bool +isCharUTF8Case4 (CharUTF8 !w) = (w .&. 0x08) == 0 +{-# INLINE isCharUTF8Case4 #-} diff --git a/bundled/Basement/UTF8/Table.hs b/bundled/Basement/UTF8/Table.hs new file mode 100644 index 0000000..4e63ac6 --- /dev/null +++ b/bundled/Basement/UTF8/Table.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Basement.UTF8.Table +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- UTF8 lookup tables for fast continuation & nb bytes per header queries +{-# LANGUAGE MagicHash #-} +module Basement.UTF8.Table + ( isContinuation + , isContinuation2 + , isContinuation3 + , getNbBytes + , isContinuation# + , isContinuationW# + , getNbBytes# + ) where + +import GHC.Prim (Word#, Int#, Addr#, indexWord8OffAddr#, word2Int#) +import GHC.Types +import GHC.Word +import Basement.Compat.Base +import Basement.Compat.Primitive +import Basement.Bits +import Basement.UTF8.Types (StepASCII(..)) + +-- | Check if the byte is a continuation byte +isContinuation :: Word8 -> Bool +isContinuation (W8# w) = isContinuation# w +{-# INLINE isContinuation #-} + +isContinuation2 :: Word8 -> Word8 -> Bool +isContinuation2 !w1 !w2 = mask w1 && mask w2 + where + mask v = (v .&. 0xC0) == 0x80 +{-# INLINE isContinuation2 #-} + +isContinuation3 :: Word8 -> Word8 -> Word8 -> Bool +isContinuation3 !w1 !w2 !w3 = + mask w1 && mask w2 && mask w3 + where + mask v = (v .&. 0xC0) == 0x80 +{-# INLINE isContinuation3 #-} + +-- | Number of bytes associated with a specific header byte +-- +-- If the header byte is invalid then NbBytesInvalid is returned, +data NbBytesCont = NbBytesInvalid | NbBytesCont0 | NbBytesCont1 | NbBytesCont2 | NbBytesCont3 + +-- | Identical to 'NbBytesCont' but doesn't allow to represent any failure. +-- +-- Only use in validated place +data NbBytesCont_ = NbBytesCont0_ | NbBytesCont1_ | NbBytesCont2_ | NbBytesCont3_ + +-- | Get the number of following bytes given the first byte of a UTF8 sequence. +getNbBytes :: StepASCII -> Int +getNbBytes (StepASCII (W8# w)) = I# (getNbBytes# w) +{-# INLINE getNbBytes #-} + +-- | Check if the byte is a continuation byte +isContinuation# :: Word8# -> Bool +isContinuation# w = W8# (indexWord8OffAddr# (unTable contTable) (word2Int# (word8ToWord# w))) == 0 +{-# INLINE isContinuation# #-} + +-- | Check if the byte is a continuation byte +isContinuationW# :: Word# -> Bool +isContinuationW# w = W8# (indexWord8OffAddr# (unTable contTable) (word2Int# w)) == 0 +{-# INLINE isContinuationW# #-} + +-- | Get the number of following bytes given the first byte of a UTF8 sequence. +getNbBytes# :: Word8# -> Int# +getNbBytes# w = word8ToInt# (indexWord8OffAddr# (unTable headTable) (word2Int# (word8ToWord# w))) +{-# INLINE getNbBytes# #-} + +data Table = Table { unTable :: !Addr# } + +contTable :: Table +contTable = Table + "\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ + \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ + \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ + \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ + \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ + \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ + \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ + \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ + \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ + \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ + \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01"# +{-# NOINLINE contTable #-} + +headTable :: Table +headTable = Table + "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ + \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\ + \\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\ + \\x03\x03\x03\x03\x03\x03\x03\x03\xff\xff\xff\xff\xff\xff\xff\xff"# +{-# NOINLINE headTable #-} diff --git a/bundled/Basement/UTF8/Types.hs b/bundled/Basement/UTF8/Types.hs new file mode 100644 index 0000000..6f89203 --- /dev/null +++ b/bundled/Basement/UTF8/Types.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Basement.UTF8.Types + ( + -- * Stepper + Step(..) + , StepBack(..) + , StepASCII(..) + , StepDigit(..) + , isValidStepASCII + , isValidStepDigit + -- * Unicode Errors + , ValidationFailure(..) + -- * UTF8 Encoded 'Char' + , CharUTF8(..) + -- * Case Conversion + , CM (..) + ) where + +import Basement.Compat.Base +import Basement.Types.OffsetSize + +-- | Step when walking a String +-- +-- this is a return value composed of : +-- * the unicode code point read (Char) which need to be +-- between 0 and 0x10ffff (inclusive) +-- * The next offset to start reading the next unicode code point (or end) +data Step = Step {-# UNPACK #-} !Char {-# UNPACK #-} !(Offset Word8) + +-- | Similar to Step but used when processing the string from the end. +-- +-- The stepper is thus the previous character, and the offset of +-- the beginning of the previous character +data StepBack = StepBack {-# UNPACK #-} !Char {-# UNPACK #-} !(Offset Word8) + +-- | Step when processing digits. the value is between 0 and 9 to be valid +newtype StepDigit = StepDigit Word8 + +-- | Step when processing ASCII character +newtype StepASCII = StepASCII { stepAsciiRawValue :: Word8 } + +-- | Specialized tuple used for case mapping. +data CM = CM {-# UNPACK #-} !Char {-# UNPACK #-} !Char {-# UNPACK #-} !Char deriving (Eq) + +-- | Represent an already encoded UTF8 Char where the the lowest 8 bits is the start of the +-- sequence. If this contains a multi bytes sequence then each higher 8 bits are filled with +-- the remaining sequence 8 bits per 8 bits. +-- +-- For example: +-- 'A' => U+0041 => 41 => 0x00000041 +-- '€ => U+20AC => E2 82 AC => 0x00AC82E2 +-- '𐍈' => U+10348 => F0 90 8D 88 => 0x888D90F0 +-- +newtype CharUTF8 = CharUTF8 Word32 + +isValidStepASCII :: StepASCII -> Bool +isValidStepASCII (StepASCII w) = w < 0x80 + +isValidStepDigit :: StepDigit -> Bool +isValidStepDigit (StepDigit w) = w < 0xa + +-- | Possible failure related to validating bytes of UTF8 sequences. +data ValidationFailure = InvalidHeader + | InvalidContinuation + | MissingByte + | BuildingFailure + deriving (Show,Eq,Typeable) + +instance Exception ValidationFailure diff --git a/bundled/Crypto/Cipher/AES.hs b/bundled/Crypto/Cipher/AES.hs new file mode 100644 index 0000000..8ba303f --- /dev/null +++ b/bundled/Crypto/Cipher/AES.hs @@ -0,0 +1,70 @@ +-- | +-- Module : Crypto.Cipher.AES +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : good +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Crypto.Cipher.AES + ( AES128 + , AES192 + , AES256 + ) where + +import Crypto.Error +import Crypto.Cipher.Types +import Crypto.Cipher.Utils +import Crypto.Cipher.Types.Block +import Crypto.Cipher.AES.Primitive +import Crypto.Internal.Imports + +-- | AES with 128 bit key +newtype AES128 = AES128 AES + deriving (NFData) + +-- | AES with 192 bit key +newtype AES192 = AES192 AES + deriving (NFData) + +-- | AES with 256 bit key +newtype AES256 = AES256 AES + deriving (NFData) + +instance Cipher AES128 where + cipherName _ = "AES128" + cipherKeySize _ = KeySizeFixed 16 + cipherInit k = AES128 <$> (initAES =<< validateKeySize (undefined :: AES128) k) + +instance Cipher AES192 where + cipherName _ = "AES192" + cipherKeySize _ = KeySizeFixed 24 + cipherInit k = AES192 <$> (initAES =<< validateKeySize (undefined :: AES192) k) + +instance Cipher AES256 where + cipherName _ = "AES256" + cipherKeySize _ = KeySizeFixed 32 + cipherInit k = AES256 <$> (initAES =<< validateKeySize (undefined :: AES256) k) + + +#define INSTANCE_BLOCKCIPHER(CSTR) \ +instance BlockCipher CSTR where \ + { blockSize _ = 16 \ + ; ecbEncrypt (CSTR aes) = encryptECB aes \ + ; ecbDecrypt (CSTR aes) = decryptECB aes \ + ; cbcEncrypt (CSTR aes) (IV iv) = encryptCBC aes (IV iv) \ + ; cbcDecrypt (CSTR aes) (IV iv) = decryptCBC aes (IV iv) \ + ; ctrCombine (CSTR aes) (IV iv) = encryptCTR aes (IV iv) \ + ; aeadInit AEAD_GCM (CSTR aes) iv = CryptoPassed $ AEAD (gcmMode aes) (gcmInit aes iv) \ + ; aeadInit AEAD_OCB (CSTR aes) iv = CryptoPassed $ AEAD (ocbMode aes) (ocbInit aes iv) \ + ; aeadInit (AEAD_CCM n m l) (CSTR aes) iv = AEAD (ccmMode aes) <$> ccmInit aes iv n m l \ + ; aeadInit _ _ _ = CryptoFailed CryptoError_AEADModeNotSupported \ + }; \ +instance BlockCipher128 CSTR where \ + { xtsEncrypt (CSTR aes1, CSTR aes2) (IV iv) = encryptXTS (aes1,aes2) (IV iv) \ + ; xtsDecrypt (CSTR aes1, CSTR aes2) (IV iv) = decryptXTS (aes1,aes2) (IV iv) \ + }; + +INSTANCE_BLOCKCIPHER(AES128) +INSTANCE_BLOCKCIPHER(AES192) +INSTANCE_BLOCKCIPHER(AES256) diff --git a/bundled/Crypto/Cipher/AES/Primitive.hs b/bundled/Crypto/Cipher/AES/Primitive.hs new file mode 100644 index 0000000..5c03a93 --- /dev/null +++ b/bundled/Crypto/Cipher/AES/Primitive.hs @@ -0,0 +1,645 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | +-- Module : Crypto.Cipher.AES.Primitive +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : good +-- +module Crypto.Cipher.AES.Primitive + ( + -- * Block cipher data types + AES + + -- * Authenticated encryption block cipher types + , AESGCM + , AESOCB + + -- * Creation + , initAES + + -- * Miscellanea + , genCTR + , genCounter + + -- * Encryption + , encryptECB + , encryptCBC + , encryptCTR + , encryptXTS + + -- * Decryption + , decryptECB + , decryptCBC + , decryptCTR + , decryptXTS + + -- * CTR with 32-bit wrapping + , combineC32 + + -- * Incremental GCM + , gcmMode + , gcmInit + + -- * Incremental OCB + , ocbMode + , ocbInit + + -- * CCM + , ccmMode + , ccmInit + ) where + +import Data.Word +import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.String + +import Crypto.Error +import Crypto.Cipher.Types +import Crypto.Cipher.Types.Block (IV(..)) +import Crypto.Internal.Compat +import Crypto.Internal.Imports +import Crypto.Internal.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes, withByteArray) +import qualified Crypto.Internal.ByteArray as B + +instance Cipher AES where + cipherName _ = "AES" + cipherKeySize _ = KeySizeEnum [16,24,32] + cipherInit k = initAES k + +instance BlockCipher AES where + blockSize _ = 16 + ecbEncrypt = encryptECB + ecbDecrypt = decryptECB + cbcEncrypt = encryptCBC + cbcDecrypt = decryptCBC + ctrCombine = encryptCTR + aeadInit AEAD_GCM aes iv = CryptoPassed $ AEAD (gcmMode aes) (gcmInit aes iv) + aeadInit AEAD_OCB aes iv = CryptoPassed $ AEAD (ocbMode aes) (ocbInit aes iv) + aeadInit (AEAD_CCM n m l) aes iv = AEAD (ccmMode aes) <$> ccmInit aes iv n m l + aeadInit _ _ _ = CryptoFailed CryptoError_AEADModeNotSupported +instance BlockCipher128 AES where + xtsEncrypt = encryptXTS + xtsDecrypt = decryptXTS + +-- | Create an AES AEAD implementation for GCM +gcmMode :: AES -> AEADModeImpl AESGCM +gcmMode aes = AEADModeImpl + { aeadImplAppendHeader = gcmAppendAAD + , aeadImplEncrypt = gcmAppendEncrypt aes + , aeadImplDecrypt = gcmAppendDecrypt aes + , aeadImplFinalize = gcmFinish aes + } + +-- | Create an AES AEAD implementation for OCB +ocbMode :: AES -> AEADModeImpl AESOCB +ocbMode aes = AEADModeImpl + { aeadImplAppendHeader = ocbAppendAAD aes + , aeadImplEncrypt = ocbAppendEncrypt aes + , aeadImplDecrypt = ocbAppendDecrypt aes + , aeadImplFinalize = ocbFinish aes + } + +-- | Create an AES AEAD implementation for CCM +ccmMode :: AES -> AEADModeImpl AESCCM +ccmMode aes = AEADModeImpl + { aeadImplAppendHeader = ccmAppendAAD aes + , aeadImplEncrypt = ccmEncrypt aes + , aeadImplDecrypt = ccmDecrypt aes + , aeadImplFinalize = ccmFinish aes + } + + +-- | AES Context (pre-processed key) +newtype AES = AES ScrubbedBytes + deriving (NFData) + +-- | AESGCM State +newtype AESGCM = AESGCM ScrubbedBytes + deriving (NFData) + +-- | AESOCB State +newtype AESOCB = AESOCB ScrubbedBytes + deriving (NFData) + +-- | AESCCM State +newtype AESCCM = AESCCM ScrubbedBytes + deriving (NFData) + +sizeGCM :: Int +sizeGCM = 320 + +sizeOCB :: Int +sizeOCB = 160 + +sizeCCM :: Int +sizeCCM = 80 + +keyToPtr :: AES -> (Ptr AES -> IO a) -> IO a +keyToPtr (AES b) f = withByteArray b (f . castPtr) + +ivToPtr :: ByteArrayAccess iv => iv -> (Ptr Word8 -> IO a) -> IO a +ivToPtr iv f = withByteArray iv (f . castPtr) + + +ivCopyPtr :: IV AES -> (Ptr Word8 -> IO a) -> IO (a, IV AES) +ivCopyPtr (IV iv) f = (\(x,y) -> (x, IV y)) `fmap` copyAndModify iv f + where + copyAndModify :: ByteArray ba => ba -> (Ptr Word8 -> IO a) -> IO (a, ba) + copyAndModify ba f' = B.copyRet ba f' + +withKeyAndIV :: ByteArrayAccess iv => AES -> iv -> (Ptr AES -> Ptr Word8 -> IO a) -> IO a +withKeyAndIV ctx iv f = keyToPtr ctx $ \kptr -> ivToPtr iv $ \ivp -> f kptr ivp + +withKey2AndIV :: ByteArrayAccess iv => AES -> AES -> iv -> (Ptr AES -> Ptr AES -> Ptr Word8 -> IO a) -> IO a +withKey2AndIV key1 key2 iv f = + keyToPtr key1 $ \kptr1 -> keyToPtr key2 $ \kptr2 -> ivToPtr iv $ \ivp -> f kptr1 kptr2 ivp + +withGCMKeyAndCopySt :: AES -> AESGCM -> (Ptr AESGCM -> Ptr AES -> IO a) -> IO (a, AESGCM) +withGCMKeyAndCopySt aes (AESGCM gcmSt) f = + keyToPtr aes $ \aesPtr -> do + newSt <- B.copy gcmSt (\_ -> return ()) + a <- withByteArray newSt $ \gcmStPtr -> f (castPtr gcmStPtr) aesPtr + return (a, AESGCM newSt) + +withNewGCMSt :: AESGCM -> (Ptr AESGCM -> IO ()) -> IO AESGCM +withNewGCMSt (AESGCM gcmSt) f = B.copy gcmSt (f . castPtr) >>= \sm2 -> return (AESGCM sm2) + +withOCBKeyAndCopySt :: AES -> AESOCB -> (Ptr AESOCB -> Ptr AES -> IO a) -> IO (a, AESOCB) +withOCBKeyAndCopySt aes (AESOCB gcmSt) f = + keyToPtr aes $ \aesPtr -> do + newSt <- B.copy gcmSt (\_ -> return ()) + a <- withByteArray newSt $ \gcmStPtr -> f (castPtr gcmStPtr) aesPtr + return (a, AESOCB newSt) + +withCCMKeyAndCopySt :: AES -> AESCCM -> (Ptr AESCCM -> Ptr AES -> IO a) -> IO (a, AESCCM) +withCCMKeyAndCopySt aes (AESCCM ccmSt) f = + keyToPtr aes $ \aesPtr -> do + newSt <- B.copy ccmSt (\_ -> return ()) + a <- withByteArray newSt $ \ccmStPtr -> f (castPtr ccmStPtr) aesPtr + return (a, AESCCM newSt) + +-- | Initialize a new context with a key +-- +-- Key needs to be of length 16, 24 or 32 bytes. Any other values will return failure +initAES :: ByteArrayAccess key => key -> CryptoFailable AES +initAES k + | len == 16 = CryptoPassed $ initWithRounds 10 + | len == 24 = CryptoPassed $ initWithRounds 12 + | len == 32 = CryptoPassed $ initWithRounds 14 + | otherwise = CryptoFailed CryptoError_KeySizeInvalid + where len = B.length k + initWithRounds nbR = AES $ B.allocAndFreeze (16+2*2*16*nbR) aesInit + aesInit ptr = withByteArray k $ \ikey -> + c_aes_init (castPtr ptr) (castPtr ikey) (fromIntegral len) + +-- | encrypt using Electronic Code Book (ECB) +{-# NOINLINE encryptECB #-} +encryptECB :: ByteArray ba => AES -> ba -> ba +encryptECB = doECB c_aes_encrypt_ecb + +-- | encrypt using Cipher Block Chaining (CBC) +{-# NOINLINE encryptCBC #-} +encryptCBC :: ByteArray ba + => AES -- ^ AES Context + -> IV AES -- ^ Initial vector of AES block size + -> ba -- ^ plaintext + -> ba -- ^ ciphertext +encryptCBC = doCBC c_aes_encrypt_cbc + +-- | generate a counter mode pad. this is generally xor-ed to an input +-- to make the standard counter mode block operations. +-- +-- if the length requested is not a multiple of the block cipher size, +-- more data will be returned, so that the returned bytearray is +-- a multiple of the block cipher size. +{-# NOINLINE genCTR #-} +genCTR :: ByteArray ba + => AES -- ^ Cipher Key. + -> IV AES -- ^ usually a 128 bit integer. + -> Int -- ^ length of bytes required. + -> ba +genCTR ctx (IV iv) len + | len <= 0 = B.empty + | otherwise = B.allocAndFreeze (nbBlocks * 16) generate + where generate o = withKeyAndIV ctx iv $ \k i -> c_aes_gen_ctr (castPtr o) k i (fromIntegral nbBlocks) + (nbBlocks',r) = len `quotRem` 16 + nbBlocks = if r == 0 then nbBlocks' else nbBlocks' + 1 + +-- | generate a counter mode pad. this is generally xor-ed to an input +-- to make the standard counter mode block operations. +-- +-- if the length requested is not a multiple of the block cipher size, +-- more data will be returned, so that the returned bytearray is +-- a multiple of the block cipher size. +-- +-- Similiar to 'genCTR' but also return the next IV for continuation +{-# NOINLINE genCounter #-} +genCounter :: ByteArray ba + => AES + -> IV AES + -> Int + -> (ba, IV AES) +genCounter ctx iv len + | len <= 0 = (B.empty, iv) + | otherwise = unsafeDoIO $ + keyToPtr ctx $ \k -> + ivCopyPtr iv $ \i -> + B.alloc outputLength $ \o -> do + c_aes_gen_ctr_cont (castPtr o) k i (fromIntegral nbBlocks) + where + (nbBlocks',r) = len `quotRem` 16 + nbBlocks = if r == 0 then nbBlocks' else nbBlocks' + 1 + outputLength = nbBlocks * 16 + +{- TODO: when genCTR has same AESIV requirements for IV, add the following rules: + - RULES "snd . genCounter" forall ctx iv len . snd (genCounter ctx iv len) = genCTR ctx iv len + -} + +-- | encrypt using Counter mode (CTR) +-- +-- in CTR mode encryption and decryption is the same operation. +{-# NOINLINE encryptCTR #-} +encryptCTR :: ByteArray ba + => AES -- ^ AES Context + -> IV AES -- ^ initial vector of AES block size (usually representing a 128 bit integer) + -> ba -- ^ plaintext input + -> ba -- ^ ciphertext output +encryptCTR ctx iv input + | len <= 0 = B.empty + | B.length iv /= 16 = error $ "AES error: IV length must be block size (16). Its length is: " ++ (show $ B.length iv) + | otherwise = B.allocAndFreeze len doEncrypt + where doEncrypt o = withKeyAndIV ctx iv $ \k v -> withByteArray input $ \i -> + c_aes_encrypt_ctr (castPtr o) k v i (fromIntegral len) + len = B.length input + +-- | encrypt using XTS +-- +-- the first key is the normal block encryption key +-- the second key is used for the initial block tweak +{-# NOINLINE encryptXTS #-} +encryptXTS :: ByteArray ba + => (AES,AES) -- ^ AES cipher and tweak context + -> IV AES -- ^ a 128 bits IV, typically a sector or a block offset in XTS + -> Word32 -- ^ number of rounds to skip, also seen a 16 byte offset in the sector or block. + -> ba -- ^ input to encrypt + -> ba -- ^ output encrypted +encryptXTS = doXTS c_aes_encrypt_xts + +-- | decrypt using Electronic Code Book (ECB) +{-# NOINLINE decryptECB #-} +decryptECB :: ByteArray ba => AES -> ba -> ba +decryptECB = doECB c_aes_decrypt_ecb + +-- | decrypt using Cipher block chaining (CBC) +{-# NOINLINE decryptCBC #-} +decryptCBC :: ByteArray ba => AES -> IV AES -> ba -> ba +decryptCBC = doCBC c_aes_decrypt_cbc + +-- | decrypt using Counter mode (CTR). +-- +-- in CTR mode encryption and decryption is the same operation. +decryptCTR :: ByteArray ba + => AES -- ^ AES Context + -> IV AES -- ^ initial vector, usually representing a 128 bit integer + -> ba -- ^ ciphertext input + -> ba -- ^ plaintext output +decryptCTR = encryptCTR + +-- | decrypt using XTS +{-# NOINLINE decryptXTS #-} +decryptXTS :: ByteArray ba + => (AES,AES) -- ^ AES cipher and tweak context + -> IV AES -- ^ a 128 bits IV, typically a sector or a block offset in XTS + -> Word32 -- ^ number of rounds to skip, also seen a 16 byte offset in the sector or block. + -> ba -- ^ input to decrypt + -> ba -- ^ output decrypted +decryptXTS = doXTS c_aes_decrypt_xts + +-- | encrypt/decrypt using Counter mode (32-bit wrapping used in AES-GCM-SIV) +{-# NOINLINE combineC32 #-} +combineC32 :: ByteArray ba + => AES -- ^ AES Context + -> IV AES -- ^ initial vector of AES block size (usually representing a 128 bit integer) + -> ba -- ^ plaintext input + -> ba -- ^ ciphertext output +combineC32 ctx iv input + | len <= 0 = B.empty + | B.length iv /= 16 = error $ "AES error: IV length must be block size (16). Its length is: " ++ show (B.length iv) + | otherwise = B.allocAndFreeze len doEncrypt + where doEncrypt o = withKeyAndIV ctx iv $ \k v -> withByteArray input $ \i -> + c_aes_encrypt_c32 (castPtr o) k v i (fromIntegral len) + len = B.length input + +{-# INLINE doECB #-} +doECB :: ByteArray ba + => (Ptr b -> Ptr AES -> CString -> CUInt -> IO ()) + -> AES -> ba -> ba +doECB f ctx input + | len == 0 = B.empty + | r /= 0 = error $ "Encryption error: input length must be a multiple of block size (16). Its length is: " ++ (show len) + | otherwise = + B.allocAndFreeze len $ \o -> + keyToPtr ctx $ \k -> + withByteArray input $ \i -> + f (castPtr o) k i (fromIntegral nbBlocks) + where (nbBlocks, r) = len `quotRem` 16 + len = B.length input + +{-# INLINE doCBC #-} +doCBC :: ByteArray ba + => (Ptr b -> Ptr AES -> Ptr Word8 -> CString -> CUInt -> IO ()) + -> AES -> IV AES -> ba -> ba +doCBC f ctx (IV iv) input + | len == 0 = B.empty + | r /= 0 = error $ "Encryption error: input length must be a multiple of block size (16). Its length is: " ++ (show len) + | otherwise = B.allocAndFreeze len $ \o -> + withKeyAndIV ctx iv $ \k v -> + withByteArray input $ \i -> + f (castPtr o) k v i (fromIntegral nbBlocks) + where (nbBlocks, r) = len `quotRem` 16 + len = B.length input + +{-# INLINE doXTS #-} +doXTS :: ByteArray ba + => (Ptr b -> Ptr AES -> Ptr AES -> Ptr Word8 -> CUInt -> CString -> CUInt -> IO ()) + -> (AES, AES) + -> IV AES + -> Word32 + -> ba + -> ba +doXTS f (key1,key2) iv spoint input + | len == 0 = B.empty + | r /= 0 = error $ "Encryption error: input length must be a multiple of block size (16) for now. Its length is: " ++ (show len) + | otherwise = B.allocAndFreeze len $ \o -> withKey2AndIV key1 key2 iv $ \k1 k2 v -> withByteArray input $ \i -> + f (castPtr o) k1 k2 v (fromIntegral spoint) i (fromIntegral nbBlocks) + where (nbBlocks, r) = len `quotRem` 16 + len = B.length input + +------------------------------------------------------------------------ +-- GCM +------------------------------------------------------------------------ + +-- | initialize a gcm context +{-# NOINLINE gcmInit #-} +gcmInit :: ByteArrayAccess iv => AES -> iv -> AESGCM +gcmInit ctx iv = unsafeDoIO $ do + sm <- B.alloc sizeGCM $ \gcmStPtr -> + withKeyAndIV ctx iv $ \k v -> + c_aes_gcm_init (castPtr gcmStPtr) k v (fromIntegral $ B.length iv) + return $ AESGCM sm + +-- | append data which is only going to be authenticated to the GCM context. +-- +-- needs to happen after initialization and before appending encryption/decryption data. +{-# NOINLINE gcmAppendAAD #-} +gcmAppendAAD :: ByteArrayAccess aad => AESGCM -> aad -> AESGCM +gcmAppendAAD gcmSt input = unsafeDoIO doAppend + where doAppend = + withNewGCMSt gcmSt $ \gcmStPtr -> + withByteArray input $ \i -> + c_aes_gcm_aad gcmStPtr i (fromIntegral $ B.length input) + +-- | append data to encrypt and append to the GCM context +-- +-- the bytearray needs to be a multiple of AES block size, unless it's the last call to this function. +-- needs to happen after AAD appending, or after initialization if no AAD data. +{-# NOINLINE gcmAppendEncrypt #-} +gcmAppendEncrypt :: ByteArray ba => AES -> AESGCM -> ba -> (ba, AESGCM) +gcmAppendEncrypt ctx gcm input = unsafeDoIO $ withGCMKeyAndCopySt ctx gcm doEnc + where len = B.length input + doEnc gcmStPtr aesPtr = + B.alloc len $ \o -> + withByteArray input $ \i -> + c_aes_gcm_encrypt (castPtr o) gcmStPtr aesPtr i (fromIntegral len) + +-- | append data to decrypt and append to the GCM context +-- +-- the bytearray needs to be a multiple of AES block size, unless it's the last call to this function. +-- needs to happen after AAD appending, or after initialization if no AAD data. +{-# NOINLINE gcmAppendDecrypt #-} +gcmAppendDecrypt :: ByteArray ba => AES -> AESGCM -> ba -> (ba, AESGCM) +gcmAppendDecrypt ctx gcm input = unsafeDoIO $ withGCMKeyAndCopySt ctx gcm doDec + where len = B.length input + doDec gcmStPtr aesPtr = + B.alloc len $ \o -> + withByteArray input $ \i -> + c_aes_gcm_decrypt (castPtr o) gcmStPtr aesPtr i (fromIntegral len) + +-- | Generate the Tag from GCM context +{-# NOINLINE gcmFinish #-} +gcmFinish :: AES -> AESGCM -> Int -> AuthTag +gcmFinish ctx gcm taglen = AuthTag $ B.take taglen computeTag + where computeTag = B.allocAndFreeze 16 $ \t -> + withGCMKeyAndCopySt ctx gcm (c_aes_gcm_finish (castPtr t)) >> return () + +------------------------------------------------------------------------ +-- OCB v3 +------------------------------------------------------------------------ + +-- | initialize an ocb context +{-# NOINLINE ocbInit #-} +ocbInit :: ByteArrayAccess iv => AES -> iv -> AESOCB +ocbInit ctx iv = unsafeDoIO $ do + sm <- B.alloc sizeOCB $ \ocbStPtr -> + withKeyAndIV ctx iv $ \k v -> + c_aes_ocb_init (castPtr ocbStPtr) k v (fromIntegral $ B.length iv) + return $ AESOCB sm + +-- | append data which is going to just be authenticated to the OCB context. +-- +-- need to happen after initialization and before appending encryption/decryption data. +{-# NOINLINE ocbAppendAAD #-} +ocbAppendAAD :: ByteArrayAccess aad => AES -> AESOCB -> aad -> AESOCB +ocbAppendAAD ctx ocb input = unsafeDoIO (snd `fmap` withOCBKeyAndCopySt ctx ocb doAppend) + where doAppend ocbStPtr aesPtr = + withByteArray input $ \i -> + c_aes_ocb_aad ocbStPtr aesPtr i (fromIntegral $ B.length input) + +-- | append data to encrypt and append to the OCB context +-- +-- the bytearray needs to be a multiple of the AES block size, unless it's the last call to this function. +-- need to happen after AAD appending, or after initialization if no AAD data. +{-# NOINLINE ocbAppendEncrypt #-} +ocbAppendEncrypt :: ByteArray ba => AES -> AESOCB -> ba -> (ba, AESOCB) +ocbAppendEncrypt ctx ocb input = unsafeDoIO $ withOCBKeyAndCopySt ctx ocb doEnc + where len = B.length input + doEnc ocbStPtr aesPtr = + B.alloc len $ \o -> + withByteArray input $ \i -> + c_aes_ocb_encrypt (castPtr o) ocbStPtr aesPtr i (fromIntegral len) + +-- | append data to decrypt and append to the OCB context +-- +-- the bytearray needs to be a multiple of the AES block size, unless it's the last call to this function. +-- need to happen after AAD appending, or after initialization if no AAD data. +{-# NOINLINE ocbAppendDecrypt #-} +ocbAppendDecrypt :: ByteArray ba => AES -> AESOCB -> ba -> (ba, AESOCB) +ocbAppendDecrypt ctx ocb input = unsafeDoIO $ withOCBKeyAndCopySt ctx ocb doDec + where len = B.length input + doDec ocbStPtr aesPtr = + B.alloc len $ \o -> + withByteArray input $ \i -> + c_aes_ocb_decrypt (castPtr o) ocbStPtr aesPtr i (fromIntegral len) + +-- | Generate the Tag from OCB context +{-# NOINLINE ocbFinish #-} +ocbFinish :: AES -> AESOCB -> Int -> AuthTag +ocbFinish ctx ocb taglen = AuthTag $ B.take taglen computeTag + where computeTag = B.allocAndFreeze 16 $ \t -> + withOCBKeyAndCopySt ctx ocb (c_aes_ocb_finish (castPtr t)) >> return () + +ccmGetM :: CCM_M -> Int +ccmGetL :: CCM_L -> Int +ccmGetM m = case m of + CCM_M4 -> 4 + CCM_M6 -> 6 + CCM_M8 -> 8 + CCM_M10 -> 10 + CCM_M12 -> 12 + CCM_M14 -> 14 + CCM_M16 -> 16 + +ccmGetL l = case l of + CCM_L2 -> 2 + CCM_L3 -> 3 + CCM_L4 -> 4 + +-- | initialize a ccm context +{-# NOINLINE ccmInit #-} +ccmInit :: ByteArrayAccess iv => AES -> iv -> Int -> CCM_M -> CCM_L -> CryptoFailable AESCCM +ccmInit ctx iv n m l + | 15 - li /= B.length iv = CryptoFailed CryptoError_IvSizeInvalid + | otherwise = unsafeDoIO $ do + sm <- B.alloc sizeCCM $ \ccmStPtr -> + withKeyAndIV ctx iv $ \k v -> + c_aes_ccm_init (castPtr ccmStPtr) k v (fromIntegral $ B.length iv) (fromIntegral n) (fromIntegral mi) (fromIntegral li) + return $ CryptoPassed (AESCCM sm) + where + mi = ccmGetM m + li = ccmGetL l + +-- | append data which is only going to be authenticated to the CCM context. +-- +-- needs to happen after initialization and before appending encryption/decryption data. +{-# NOINLINE ccmAppendAAD #-} +ccmAppendAAD :: ByteArrayAccess aad => AES -> AESCCM -> aad -> AESCCM +ccmAppendAAD ctx ccm input = unsafeDoIO $ snd <$> withCCMKeyAndCopySt ctx ccm doAppend + where doAppend ccmStPtr aesPtr = + withByteArray input $ \i -> c_aes_ccm_aad ccmStPtr aesPtr i (fromIntegral $ B.length input) + +-- | append data to encrypt and append to the CCM context +-- +-- the bytearray needs to be a multiple of AES block size, unless it's the last call to this function. +-- needs to happen after AAD appending, or after initialization if no AAD data. +{-# NOINLINE ccmEncrypt #-} +ccmEncrypt :: ByteArray ba => AES -> AESCCM -> ba -> (ba, AESCCM) +ccmEncrypt ctx ccm input = unsafeDoIO $ withCCMKeyAndCopySt ctx ccm cbcmacAndIv + where len = B.length input + cbcmacAndIv ccmStPtr aesPtr = + B.alloc len $ \o -> + withByteArray input $ \i -> + c_aes_ccm_encrypt (castPtr o) ccmStPtr aesPtr i (fromIntegral len) + +-- | append data to decrypt and append to the CCM context +-- +-- the bytearray needs to be a multiple of AES block size, unless it's the last call to this function. +-- needs to happen after AAD appending, or after initialization if no AAD data. +{-# NOINLINE ccmDecrypt #-} +ccmDecrypt :: ByteArray ba => AES -> AESCCM -> ba -> (ba, AESCCM) +ccmDecrypt ctx ccm input = unsafeDoIO $ withCCMKeyAndCopySt ctx ccm cbcmacAndIv + where len = B.length input + cbcmacAndIv ccmStPtr aesPtr = + B.alloc len $ \o -> + withByteArray input $ \i -> + c_aes_ccm_decrypt (castPtr o) ccmStPtr aesPtr i (fromIntegral len) + +-- | Generate the Tag from CCM context +{-# NOINLINE ccmFinish #-} +ccmFinish :: AES -> AESCCM -> Int -> AuthTag +ccmFinish ctx ccm taglen = AuthTag $ B.take taglen computeTag + where computeTag = B.allocAndFreeze 16 $ \t -> + withCCMKeyAndCopySt ctx ccm (c_aes_ccm_finish (castPtr t)) >> return () + +------------------------------------------------------------------------ +foreign import ccall "cryptonite_aes.h cryptonite_aes_initkey" + c_aes_init :: Ptr AES -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_encrypt_ecb" + c_aes_encrypt_ecb :: CString -> Ptr AES -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_decrypt_ecb" + c_aes_decrypt_ecb :: CString -> Ptr AES -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_encrypt_cbc" + c_aes_encrypt_cbc :: CString -> Ptr AES -> Ptr Word8 -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_decrypt_cbc" + c_aes_decrypt_cbc :: CString -> Ptr AES -> Ptr Word8 -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_encrypt_xts" + c_aes_encrypt_xts :: CString -> Ptr AES -> Ptr AES -> Ptr Word8 -> CUInt -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_decrypt_xts" + c_aes_decrypt_xts :: CString -> Ptr AES -> Ptr AES -> Ptr Word8 -> CUInt -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_gen_ctr" + c_aes_gen_ctr :: CString -> Ptr AES -> Ptr Word8 -> CUInt -> IO () + +foreign import ccall unsafe "cryptonite_aes.h cryptonite_aes_gen_ctr_cont" + c_aes_gen_ctr_cont :: CString -> Ptr AES -> Ptr Word8 -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_encrypt_ctr" + c_aes_encrypt_ctr :: CString -> Ptr AES -> Ptr Word8 -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_encrypt_c32" + c_aes_encrypt_c32 :: CString -> Ptr AES -> Ptr Word8 -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_gcm_init" + c_aes_gcm_init :: Ptr AESGCM -> Ptr AES -> Ptr Word8 -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_gcm_aad" + c_aes_gcm_aad :: Ptr AESGCM -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_gcm_encrypt" + c_aes_gcm_encrypt :: CString -> Ptr AESGCM -> Ptr AES -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_gcm_decrypt" + c_aes_gcm_decrypt :: CString -> Ptr AESGCM -> Ptr AES -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_gcm_finish" + c_aes_gcm_finish :: CString -> Ptr AESGCM -> Ptr AES -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_ocb_init" + c_aes_ocb_init :: Ptr AESOCB -> Ptr AES -> Ptr Word8 -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_ocb_aad" + c_aes_ocb_aad :: Ptr AESOCB -> Ptr AES -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_ocb_encrypt" + c_aes_ocb_encrypt :: CString -> Ptr AESOCB -> Ptr AES -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_ocb_decrypt" + c_aes_ocb_decrypt :: CString -> Ptr AESOCB -> Ptr AES -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_ocb_finish" + c_aes_ocb_finish :: CString -> Ptr AESOCB -> Ptr AES -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_ccm_init" + c_aes_ccm_init :: Ptr AESCCM -> Ptr AES -> Ptr Word8 -> CUInt -> CUInt -> CInt -> CInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_ccm_aad" + c_aes_ccm_aad :: Ptr AESCCM -> Ptr AES -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_ccm_encrypt" + c_aes_ccm_encrypt :: CString -> Ptr AESCCM -> Ptr AES -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_ccm_decrypt" + c_aes_ccm_decrypt :: CString -> Ptr AESCCM -> Ptr AES -> CString -> CUInt -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_ccm_finish" + c_aes_ccm_finish :: CString -> Ptr AESCCM -> Ptr AES -> IO () diff --git a/bundled/Crypto/Cipher/AESGCMSIV.hs b/bundled/Crypto/Cipher/AESGCMSIV.hs new file mode 100644 index 0000000..d29211a --- /dev/null +++ b/bundled/Crypto/Cipher/AESGCMSIV.hs @@ -0,0 +1,193 @@ +-- | +-- Module : Crypto.Cipher.AESGCMSIV +-- License : BSD-style +-- Maintainer : Olivier Chéron +-- Stability : experimental +-- Portability : unknown +-- +-- Implementation of AES-GCM-SIV, an AEAD scheme with nonce misuse resistance +-- defined in . +-- +-- To achieve the nonce misuse-resistance property, encryption requires two +-- passes on the plaintext, hence no streaming API is provided. This AEAD +-- operates on complete inputs held in memory. For simplicity, the +-- implementation of decryption uses a similar pattern, with performance +-- penalty compared to an implementation which is able to merge both passes. +-- +-- The specification allows inputs up to 2^36 bytes but this implementation +-- requires AAD and plaintext/ciphertext to be both smaller than 2^32 bytes. +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Crypto.Cipher.AESGCMSIV + ( Nonce + , nonce + , generateNonce + , encrypt + , decrypt + ) where + +import Data.Bits +import Data.Word + +import Foreign.C.Types +import Foreign.C.String +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (peekElemOff, poke, pokeElemOff) + +import Data.ByteArray +import qualified Data.ByteArray as B +import Data.Memory.Endian (toLE) +import Data.Memory.PtrMethods (memXor) + +import Crypto.Cipher.AES.Primitive +import Crypto.Cipher.Types +import Crypto.Error +import Crypto.Internal.Compat (unsafeDoIO) +import Crypto.Random + + +-- 12-byte nonces + +-- | Nonce value for AES-GCM-SIV, always 12 bytes. +newtype Nonce = Nonce Bytes deriving (Show, Eq, ByteArrayAccess) + +-- | Nonce smart constructor. Accepts only 12-byte inputs. +nonce :: ByteArrayAccess iv => iv -> CryptoFailable Nonce +nonce iv + | B.length iv == 12 = CryptoPassed (Nonce $ B.convert iv) + | otherwise = CryptoFailed CryptoError_IvSizeInvalid + +-- | Generate a random nonce for use with AES-GCM-SIV. +generateNonce :: MonadRandom m => m Nonce +generateNonce = Nonce <$> getRandomBytes 12 + + +-- POLYVAL (mutable context) + +newtype Polyval = Polyval Bytes + +polyvalInit :: ScrubbedBytes -> IO Polyval +polyvalInit h = Polyval <$> doInit + where doInit = B.alloc 272 $ \pctx -> B.withByteArray h $ \ph -> + c_aes_polyval_init pctx ph + +polyvalUpdate :: ByteArrayAccess ba => Polyval -> ba -> IO () +polyvalUpdate (Polyval ctx) bs = B.withByteArray ctx $ \pctx -> + B.withByteArray bs $ \pbs -> c_aes_polyval_update pctx pbs sz + where sz = fromIntegral (B.length bs) + +polyvalFinalize :: Polyval -> IO ScrubbedBytes +polyvalFinalize (Polyval ctx) = B.alloc 16 $ \dst -> + B.withByteArray ctx $ \pctx -> c_aes_polyval_finalize pctx dst + +foreign import ccall unsafe "cryptonite_aes.h cryptonite_aes_polyval_init" + c_aes_polyval_init :: Ptr Polyval -> CString -> IO () + +foreign import ccall "cryptonite_aes.h cryptonite_aes_polyval_update" + c_aes_polyval_update :: Ptr Polyval -> CString -> CUInt -> IO () + +foreign import ccall unsafe "cryptonite_aes.h cryptonite_aes_polyval_finalize" + c_aes_polyval_finalize :: Ptr Polyval -> CString -> IO () + + +-- Key Generation + +le32iv :: Word32 -> Nonce -> Bytes +le32iv n (Nonce iv) = B.allocAndFreeze 16 $ \ptr -> do + poke ptr (toLE n) + copyByteArrayToPtr iv (ptr `plusPtr` 4) + +deriveKeys :: BlockCipher128 aes => aes -> Nonce -> (ScrubbedBytes, AES) +deriveKeys aes iv = + case cipherKeySize aes of + KeySizeFixed sz | sz `mod` 8 == 0 -> + let mak = buildKey [0 .. 1] + key = buildKey [2 .. fromIntegral (sz `div` 8) + 1] + mek = throwCryptoError (cipherInit key) + in (mak, mek) + _ -> error "AESGCMSIV: invalid cipher" + where + idx n = ecbEncrypt aes (le32iv n iv) `takeView` 8 + buildKey = B.concat . map idx + + +-- Encryption and decryption + +lengthInvalid :: ByteArrayAccess ba => ba -> Bool +lengthInvalid bs + | finiteBitSize len > 32 = len >= 1 `unsafeShiftL` 32 + | otherwise = False + where len = B.length bs + +-- | AEAD encryption with the specified key and nonce. The key must be given +-- as an initialized 'Crypto.Cipher.AES.AES128' or 'Crypto.Cipher.AES.AES256' +-- cipher. +-- +-- Lengths of additional data and plaintext must be less than 2^32 bytes, +-- otherwise an exception is thrown. +encrypt :: (BlockCipher128 aes, ByteArrayAccess aad, ByteArray ba) + => aes -> Nonce -> aad -> ba -> (AuthTag, ba) +encrypt aes iv aad plaintext + | lengthInvalid aad = error "AESGCMSIV: aad is too large" + | lengthInvalid plaintext = error "AESGCMSIV: plaintext is too large" + | otherwise = (AuthTag tag, ciphertext) + where + (mak, mek) = deriveKeys aes iv + ss = getSs mak aad plaintext + tag = buildTag mek ss iv + ciphertext = combineC32 mek (transformTag tag) plaintext + +-- | AEAD decryption with the specified key and nonce. The key must be given +-- as an initialized 'Crypto.Cipher.AES.AES128' or 'Crypto.Cipher.AES.AES256' +-- cipher. +-- +-- Lengths of additional data and ciphertext must be less than 2^32 bytes, +-- otherwise an exception is thrown. +decrypt :: (BlockCipher128 aes, ByteArrayAccess aad, ByteArray ba) + => aes -> Nonce -> aad -> ba -> AuthTag -> Maybe ba +decrypt aes iv aad ciphertext (AuthTag tag) + | lengthInvalid aad = error "AESGCMSIV: aad is too large" + | lengthInvalid ciphertext = error "AESGCMSIV: ciphertext is too large" + | tag `constEq` buildTag mek ss iv = Just plaintext + | otherwise = Nothing + where + (mak, mek) = deriveKeys aes iv + ss = getSs mak aad plaintext + plaintext = combineC32 mek (transformTag tag) ciphertext + +-- Calculate S_s = POLYVAL(mak, X_1, X_2, ...). +getSs :: (ByteArrayAccess aad, ByteArrayAccess ba) + => ScrubbedBytes -> aad -> ba -> ScrubbedBytes +getSs mak aad plaintext = unsafeDoIO $ do + ctx <- polyvalInit mak + polyvalUpdate ctx aad + polyvalUpdate ctx plaintext + polyvalUpdate ctx (lb :: Bytes) -- the "length block" + polyvalFinalize ctx + where + lb = B.allocAndFreeze 16 $ \ptr -> do + pokeElemOff ptr 0 (toLE64 $ B.length aad) + pokeElemOff ptr 1 (toLE64 $ B.length plaintext) + toLE64 x = toLE (fromIntegral x * 8 :: Word64) + +-- XOR the first 12 bytes of S_s with the nonce and clear the most significant +-- bit of the last byte. +tagInput :: ScrubbedBytes -> Nonce -> Bytes +tagInput ss (Nonce iv) = + B.copyAndFreeze ss $ \ptr -> + B.withByteArray iv $ \ivPtr -> do + memXor ptr ptr ivPtr 12 + b <- peekElemOff ptr 15 + pokeElemOff ptr 15 (b .&. (0x7f :: Word8)) + +-- Encrypt the result with AES using the message-encryption key to produce the +-- tag. +buildTag :: BlockCipher128 aes => aes -> ScrubbedBytes -> Nonce -> Bytes +buildTag mek ss iv = ecbEncrypt mek (tagInput ss iv) + +-- The initial counter block is the tag with the most significant bit of the +-- last byte set to one. +transformTag :: Bytes -> IV AES +transformTag tag = toIV $ B.copyAndFreeze tag $ \ptr -> + peekElemOff ptr 15 >>= pokeElemOff ptr 15 . (.|. (0x80 :: Word8)) + where toIV bs = let Just iv = makeIV (bs :: Bytes) in iv diff --git a/bundled/Crypto/Cipher/Blowfish.hs b/bundled/Crypto/Cipher/Blowfish.hs new file mode 100644 index 0000000..040391d --- /dev/null +++ b/bundled/Crypto/Cipher/Blowfish.hs @@ -0,0 +1,67 @@ +-- | +-- Module : Crypto.Cipher.Blowfish +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : good +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Crypto.Cipher.Blowfish + ( Blowfish + , Blowfish64 + , Blowfish128 + , Blowfish256 + , Blowfish448 + ) where + +import Crypto.Internal.Imports +import Crypto.Cipher.Types +import Crypto.Cipher.Blowfish.Primitive + +-- | variable keyed blowfish state +newtype Blowfish = Blowfish Context + deriving (NFData) + +-- | 64 bit keyed blowfish state +newtype Blowfish64 = Blowfish64 Context + deriving (NFData) + +-- | 128 bit keyed blowfish state +newtype Blowfish128 = Blowfish128 Context + deriving (NFData) + +-- | 256 bit keyed blowfish state +newtype Blowfish256 = Blowfish256 Context + deriving (NFData) + +-- | 448 bit keyed blowfish state +newtype Blowfish448 = Blowfish448 Context + deriving (NFData) + +instance Cipher Blowfish where + cipherName _ = "blowfish" + cipherKeySize _ = KeySizeRange 6 56 + cipherInit k = Blowfish `fmap` initBlowfish k + +instance BlockCipher Blowfish where + blockSize _ = 8 + ecbEncrypt (Blowfish bf) = encrypt bf + ecbDecrypt (Blowfish bf) = decrypt bf + +#define INSTANCE_CIPHER(CSTR, NAME, KEYSIZE) \ +instance Cipher CSTR where \ + { cipherName _ = NAME \ + ; cipherKeySize _ = KeySizeFixed KEYSIZE \ + ; cipherInit k = CSTR `fmap` initBlowfish k \ + }; \ +instance BlockCipher CSTR where \ + { blockSize _ = 8 \ + ; ecbEncrypt (CSTR bf) = encrypt bf \ + ; ecbDecrypt (CSTR bf) = decrypt bf \ + }; + +INSTANCE_CIPHER(Blowfish64, "blowfish64", 8) +INSTANCE_CIPHER(Blowfish128, "blowfish128", 16) +INSTANCE_CIPHER(Blowfish256, "blowfish256", 32) +INSTANCE_CIPHER(Blowfish448, "blowfish448", 56) diff --git a/bundled/Crypto/Cipher/Blowfish/Box.hs b/bundled/Crypto/Cipher/Blowfish/Box.hs new file mode 100644 index 0000000..62f1adc --- /dev/null +++ b/bundled/Crypto/Cipher/Blowfish/Box.hs @@ -0,0 +1,296 @@ +-- | +-- Module : Crypto.Cipher.Blowfish.Box +-- License : BSD-style +-- Stability : experimental +-- Portability : Good +{-# LANGUAGE MagicHash #-} +module Crypto.Cipher.Blowfish.Box + ( KeySchedule(..) + , createKeySchedule + , copyKeySchedule + ) where + +import Crypto.Internal.WordArray (MutableArray32, + mutableArray32FromAddrBE, + mutableArrayRead32, + mutableArrayWrite32) + +newtype KeySchedule = KeySchedule MutableArray32 + +-- | Copy the state of one key schedule into the other. +-- The first parameter is the destination and the second the source. +copyKeySchedule :: KeySchedule -> KeySchedule -> IO () +copyKeySchedule (KeySchedule dst) (KeySchedule src) = loop 0 + where + loop 1042 = return () + loop i = do + w32 <-mutableArrayRead32 src i + mutableArrayWrite32 dst i w32 + loop (i + 1) + +-- | Create a key schedule mutable array of the pbox followed by +-- all the sboxes. +createKeySchedule :: IO KeySchedule +createKeySchedule = KeySchedule `fmap` mutableArray32FromAddrBE 1042 "\ + \\x24\x3f\x6a\x88\x85\xa3\x08\xd3\x13\x19\x8a\x2e\x03\x70\x73\x44\ + \\xa4\x09\x38\x22\x29\x9f\x31\xd0\x08\x2e\xfa\x98\xec\x4e\x6c\x89\ + \\x45\x28\x21\xe6\x38\xd0\x13\x77\xbe\x54\x66\xcf\x34\xe9\x0c\x6c\ + \\xc0\xac\x29\xb7\xc9\x7c\x50\xdd\x3f\x84\xd5\xb5\xb5\x47\x09\x17\ + \\x92\x16\xd5\xd9\x89\x79\xfb\x1b\ + \\xd1\x31\x0b\xa6\x98\xdf\xb5\xac\x2f\xfd\x72\xdb\xd0\x1a\xdf\xb7\ + \\xb8\xe1\xaf\xed\x6a\x26\x7e\x96\xba\x7c\x90\x45\xf1\x2c\x7f\x99\ + \\x24\xa1\x99\x47\xb3\x91\x6c\xf7\x08\x01\xf2\xe2\x85\x8e\xfc\x16\ + \\x63\x69\x20\xd8\x71\x57\x4e\x69\xa4\x58\xfe\xa3\xf4\x93\x3d\x7e\ + \\x0d\x95\x74\x8f\x72\x8e\xb6\x58\x71\x8b\xcd\x58\x82\x15\x4a\xee\ + \\x7b\x54\xa4\x1d\xc2\x5a\x59\xb5\x9c\x30\xd5\x39\x2a\xf2\x60\x13\ + \\xc5\xd1\xb0\x23\x28\x60\x85\xf0\xca\x41\x79\x18\xb8\xdb\x38\xef\ + \\x8e\x79\xdc\xb0\x60\x3a\x18\x0e\x6c\x9e\x0e\x8b\xb0\x1e\x8a\x3e\ + \\xd7\x15\x77\xc1\xbd\x31\x4b\x27\x78\xaf\x2f\xda\x55\x60\x5c\x60\ + \\xe6\x55\x25\xf3\xaa\x55\xab\x94\x57\x48\x98\x62\x63\xe8\x14\x40\ + \\x55\xca\x39\x6a\x2a\xab\x10\xb6\xb4\xcc\x5c\x34\x11\x41\xe8\xce\ + \\xa1\x54\x86\xaf\x7c\x72\xe9\x93\xb3\xee\x14\x11\x63\x6f\xbc\x2a\ + \\x2b\xa9\xc5\x5d\x74\x18\x31\xf6\xce\x5c\x3e\x16\x9b\x87\x93\x1e\ + \\xaf\xd6\xba\x33\x6c\x24\xcf\x5c\x7a\x32\x53\x81\x28\x95\x86\x77\ + \\x3b\x8f\x48\x98\x6b\x4b\xb9\xaf\xc4\xbf\xe8\x1b\x66\x28\x21\x93\ + \\x61\xd8\x09\xcc\xfb\x21\xa9\x91\x48\x7c\xac\x60\x5d\xec\x80\x32\ + \\xef\x84\x5d\x5d\xe9\x85\x75\xb1\xdc\x26\x23\x02\xeb\x65\x1b\x88\ + \\x23\x89\x3e\x81\xd3\x96\xac\xc5\x0f\x6d\x6f\xf3\x83\xf4\x42\x39\ + \\x2e\x0b\x44\x82\xa4\x84\x20\x04\x69\xc8\xf0\x4a\x9e\x1f\x9b\x5e\ + \\x21\xc6\x68\x42\xf6\xe9\x6c\x9a\x67\x0c\x9c\x61\xab\xd3\x88\xf0\ + \\x6a\x51\xa0\xd2\xd8\x54\x2f\x68\x96\x0f\xa7\x28\xab\x51\x33\xa3\ + \\x6e\xef\x0b\x6c\x13\x7a\x3b\xe4\xba\x3b\xf0\x50\x7e\xfb\x2a\x98\ + \\xa1\xf1\x65\x1d\x39\xaf\x01\x76\x66\xca\x59\x3e\x82\x43\x0e\x88\ + \\x8c\xee\x86\x19\x45\x6f\x9f\xb4\x7d\x84\xa5\xc3\x3b\x8b\x5e\xbe\ + \\xe0\x6f\x75\xd8\x85\xc1\x20\x73\x40\x1a\x44\x9f\x56\xc1\x6a\xa6\ + \\x4e\xd3\xaa\x62\x36\x3f\x77\x06\x1b\xfe\xdf\x72\x42\x9b\x02\x3d\ + \\x37\xd0\xd7\x24\xd0\x0a\x12\x48\xdb\x0f\xea\xd3\x49\xf1\xc0\x9b\ + \\x07\x53\x72\xc9\x80\x99\x1b\x7b\x25\xd4\x79\xd8\xf6\xe8\xde\xf7\ + \\xe3\xfe\x50\x1a\xb6\x79\x4c\x3b\x97\x6c\xe0\xbd\x04\xc0\x06\xba\ + \\xc1\xa9\x4f\xb6\x40\x9f\x60\xc4\x5e\x5c\x9e\xc2\x19\x6a\x24\x63\ + \\x68\xfb\x6f\xaf\x3e\x6c\x53\xb5\x13\x39\xb2\xeb\x3b\x52\xec\x6f\ + \\x6d\xfc\x51\x1f\x9b\x30\x95\x2c\xcc\x81\x45\x44\xaf\x5e\xbd\x09\ + \\xbe\xe3\xd0\x04\xde\x33\x4a\xfd\x66\x0f\x28\x07\x19\x2e\x4b\xb3\ + \\xc0\xcb\xa8\x57\x45\xc8\x74\x0f\xd2\x0b\x5f\x39\xb9\xd3\xfb\xdb\ + \\x55\x79\xc0\xbd\x1a\x60\x32\x0a\xd6\xa1\x00\xc6\x40\x2c\x72\x79\ + \\x67\x9f\x25\xfe\xfb\x1f\xa3\xcc\x8e\xa5\xe9\xf8\xdb\x32\x22\xf8\ + \\x3c\x75\x16\xdf\xfd\x61\x6b\x15\x2f\x50\x1e\xc8\xad\x05\x52\xab\ + \\x32\x3d\xb5\xfa\xfd\x23\x87\x60\x53\x31\x7b\x48\x3e\x00\xdf\x82\ + \\x9e\x5c\x57\xbb\xca\x6f\x8c\xa0\x1a\x87\x56\x2e\xdf\x17\x69\xdb\ + \\xd5\x42\xa8\xf6\x28\x7e\xff\xc3\xac\x67\x32\xc6\x8c\x4f\x55\x73\ + \\x69\x5b\x27\xb0\xbb\xca\x58\xc8\xe1\xff\xa3\x5d\xb8\xf0\x11\xa0\ + \\x10\xfa\x3d\x98\xfd\x21\x83\xb8\x4a\xfc\xb5\x6c\x2d\xd1\xd3\x5b\ + \\x9a\x53\xe4\x79\xb6\xf8\x45\x65\xd2\x8e\x49\xbc\x4b\xfb\x97\x90\ + \\xe1\xdd\xf2\xda\xa4\xcb\x7e\x33\x62\xfb\x13\x41\xce\xe4\xc6\xe8\ + \\xef\x20\xca\xda\x36\x77\x4c\x01\xd0\x7e\x9e\xfe\x2b\xf1\x1f\xb4\ + \\x95\xdb\xda\x4d\xae\x90\x91\x98\xea\xad\x8e\x71\x6b\x93\xd5\xa0\ + \\xd0\x8e\xd1\xd0\xaf\xc7\x25\xe0\x8e\x3c\x5b\x2f\x8e\x75\x94\xb7\ + \\x8f\xf6\xe2\xfb\xf2\x12\x2b\x64\x88\x88\xb8\x12\x90\x0d\xf0\x1c\ + \\x4f\xad\x5e\xa0\x68\x8f\xc3\x1c\xd1\xcf\xf1\x91\xb3\xa8\xc1\xad\ + \\x2f\x2f\x22\x18\xbe\x0e\x17\x77\xea\x75\x2d\xfe\x8b\x02\x1f\xa1\ + \\xe5\xa0\xcc\x0f\xb5\x6f\x74\xe8\x18\xac\xf3\xd6\xce\x89\xe2\x99\ + \\xb4\xa8\x4f\xe0\xfd\x13\xe0\xb7\x7c\xc4\x3b\x81\xd2\xad\xa8\xd9\ + \\x16\x5f\xa2\x66\x80\x95\x77\x05\x93\xcc\x73\x14\x21\x1a\x14\x77\ + \\xe6\xad\x20\x65\x77\xb5\xfa\x86\xc7\x54\x42\xf5\xfb\x9d\x35\xcf\ + \\xeb\xcd\xaf\x0c\x7b\x3e\x89\xa0\xd6\x41\x1b\xd3\xae\x1e\x7e\x49\ + \\x00\x25\x0e\x2d\x20\x71\xb3\x5e\x22\x68\x00\xbb\x57\xb8\xe0\xaf\ + \\x24\x64\x36\x9b\xf0\x09\xb9\x1e\x55\x63\x91\x1d\x59\xdf\xa6\xaa\ + \\x78\xc1\x43\x89\xd9\x5a\x53\x7f\x20\x7d\x5b\xa2\x02\xe5\xb9\xc5\ + \\x83\x26\x03\x76\x62\x95\xcf\xa9\x11\xc8\x19\x68\x4e\x73\x4a\x41\ + \\xb3\x47\x2d\xca\x7b\x14\xa9\x4a\x1b\x51\x00\x52\x9a\x53\x29\x15\ + \\xd6\x0f\x57\x3f\xbc\x9b\xc6\xe4\x2b\x60\xa4\x76\x81\xe6\x74\x00\ + \\x08\xba\x6f\xb5\x57\x1b\xe9\x1f\xf2\x96\xec\x6b\x2a\x0d\xd9\x15\ + \\xb6\x63\x65\x21\xe7\xb9\xf9\xb6\xff\x34\x05\x2e\xc5\x85\x56\x64\ + \\x53\xb0\x2d\x5d\xa9\x9f\x8f\xa1\x08\xba\x47\x99\x6e\x85\x07\x6a\ + \\x4b\x7a\x70\xe9\xb5\xb3\x29\x44\xdb\x75\x09\x2e\xc4\x19\x26\x23\ + \\xad\x6e\xa6\xb0\x49\xa7\xdf\x7d\x9c\xee\x60\xb8\x8f\xed\xb2\x66\ + \\xec\xaa\x8c\x71\x69\x9a\x17\xff\x56\x64\x52\x6c\xc2\xb1\x9e\xe1\ + \\x19\x36\x02\xa5\x75\x09\x4c\x29\xa0\x59\x13\x40\xe4\x18\x3a\x3e\ + \\x3f\x54\x98\x9a\x5b\x42\x9d\x65\x6b\x8f\xe4\xd6\x99\xf7\x3f\xd6\ + \\xa1\xd2\x9c\x07\xef\xe8\x30\xf5\x4d\x2d\x38\xe6\xf0\x25\x5d\xc1\ + \\x4c\xdd\x20\x86\x84\x70\xeb\x26\x63\x82\xe9\xc6\x02\x1e\xcc\x5e\ + \\x09\x68\x6b\x3f\x3e\xba\xef\xc9\x3c\x97\x18\x14\x6b\x6a\x70\xa1\ + \\x68\x7f\x35\x84\x52\xa0\xe2\x86\xb7\x9c\x53\x05\xaa\x50\x07\x37\ + \\x3e\x07\x84\x1c\x7f\xde\xae\x5c\x8e\x7d\x44\xec\x57\x16\xf2\xb8\ + \\xb0\x3a\xda\x37\xf0\x50\x0c\x0d\xf0\x1c\x1f\x04\x02\x00\xb3\xff\ + \\xae\x0c\xf5\x1a\x3c\xb5\x74\xb2\x25\x83\x7a\x58\xdc\x09\x21\xbd\ + \\xd1\x91\x13\xf9\x7c\xa9\x2f\xf6\x94\x32\x47\x73\x22\xf5\x47\x01\ + \\x3a\xe5\xe5\x81\x37\xc2\xda\xdc\xc8\xb5\x76\x34\x9a\xf3\xdd\xa7\ + \\xa9\x44\x61\x46\x0f\xd0\x03\x0e\xec\xc8\xc7\x3e\xa4\x75\x1e\x41\ + \\xe2\x38\xcd\x99\x3b\xea\x0e\x2f\x32\x80\xbb\xa1\x18\x3e\xb3\x31\ + \\x4e\x54\x8b\x38\x4f\x6d\xb9\x08\x6f\x42\x0d\x03\xf6\x0a\x04\xbf\ + \\x2c\xb8\x12\x90\x24\x97\x7c\x79\x56\x79\xb0\x72\xbc\xaf\x89\xaf\ + \\xde\x9a\x77\x1f\xd9\x93\x08\x10\xb3\x8b\xae\x12\xdc\xcf\x3f\x2e\ + \\x55\x12\x72\x1f\x2e\x6b\x71\x24\x50\x1a\xdd\xe6\x9f\x84\xcd\x87\ + \\x7a\x58\x47\x18\x74\x08\xda\x17\xbc\x9f\x9a\xbc\xe9\x4b\x7d\x8c\ + \\xec\x7a\xec\x3a\xdb\x85\x1d\xfa\x63\x09\x43\x66\xc4\x64\xc3\xd2\ + \\xef\x1c\x18\x47\x32\x15\xd9\x08\xdd\x43\x3b\x37\x24\xc2\xba\x16\ + \\x12\xa1\x4d\x43\x2a\x65\xc4\x51\x50\x94\x00\x02\x13\x3a\xe4\xdd\ + \\x71\xdf\xf8\x9e\x10\x31\x4e\x55\x81\xac\x77\xd6\x5f\x11\x19\x9b\ + \\x04\x35\x56\xf1\xd7\xa3\xc7\x6b\x3c\x11\x18\x3b\x59\x24\xa5\x09\ + \\xf2\x8f\xe6\xed\x97\xf1\xfb\xfa\x9e\xba\xbf\x2c\x1e\x15\x3c\x6e\ + \\x86\xe3\x45\x70\xea\xe9\x6f\xb1\x86\x0e\x5e\x0a\x5a\x3e\x2a\xb3\ + \\x77\x1f\xe7\x1c\x4e\x3d\x06\xfa\x29\x65\xdc\xb9\x99\xe7\x1d\x0f\ + \\x80\x3e\x89\xd6\x52\x66\xc8\x25\x2e\x4c\xc9\x78\x9c\x10\xb3\x6a\ + \\xc6\x15\x0e\xba\x94\xe2\xea\x78\xa5\xfc\x3c\x53\x1e\x0a\x2d\xf4\ + \\xf2\xf7\x4e\xa7\x36\x1d\x2b\x3d\x19\x39\x26\x0f\x19\xc2\x79\x60\ + \\x52\x23\xa7\x08\xf7\x13\x12\xb6\xeb\xad\xfe\x6e\xea\xc3\x1f\x66\ + \\xe3\xbc\x45\x95\xa6\x7b\xc8\x83\xb1\x7f\x37\xd1\x01\x8c\xff\x28\ + \\xc3\x32\xdd\xef\xbe\x6c\x5a\xa5\x65\x58\x21\x85\x68\xab\x98\x02\ + \\xee\xce\xa5\x0f\xdb\x2f\x95\x3b\x2a\xef\x7d\xad\x5b\x6e\x2f\x84\ + \\x15\x21\xb6\x28\x29\x07\x61\x70\xec\xdd\x47\x75\x61\x9f\x15\x10\ + \\x13\xcc\xa8\x30\xeb\x61\xbd\x96\x03\x34\xfe\x1e\xaa\x03\x63\xcf\ + \\xb5\x73\x5c\x90\x4c\x70\xa2\x39\xd5\x9e\x9e\x0b\xcb\xaa\xde\x14\ + \\xee\xcc\x86\xbc\x60\x62\x2c\xa7\x9c\xab\x5c\xab\xb2\xf3\x84\x6e\ + \\x64\x8b\x1e\xaf\x19\xbd\xf0\xca\xa0\x23\x69\xb9\x65\x5a\xbb\x50\ + \\x40\x68\x5a\x32\x3c\x2a\xb4\xb3\x31\x9e\xe9\xd5\xc0\x21\xb8\xf7\ + \\x9b\x54\x0b\x19\x87\x5f\xa0\x99\x95\xf7\x99\x7e\x62\x3d\x7d\xa8\ + \\xf8\x37\x88\x9a\x97\xe3\x2d\x77\x11\xed\x93\x5f\x16\x68\x12\x81\ + \\x0e\x35\x88\x29\xc7\xe6\x1f\xd6\x96\xde\xdf\xa1\x78\x58\xba\x99\ + \\x57\xf5\x84\xa5\x1b\x22\x72\x63\x9b\x83\xc3\xff\x1a\xc2\x46\x96\ + \\xcd\xb3\x0a\xeb\x53\x2e\x30\x54\x8f\xd9\x48\xe4\x6d\xbc\x31\x28\ + \\x58\xeb\xf2\xef\x34\xc6\xff\xea\xfe\x28\xed\x61\xee\x7c\x3c\x73\ + \\x5d\x4a\x14\xd9\xe8\x64\xb7\xe3\x42\x10\x5d\x14\x20\x3e\x13\xe0\ + \\x45\xee\xe2\xb6\xa3\xaa\xab\xea\xdb\x6c\x4f\x15\xfa\xcb\x4f\xd0\ + \\xc7\x42\xf4\x42\xef\x6a\xbb\xb5\x65\x4f\x3b\x1d\x41\xcd\x21\x05\ + \\xd8\x1e\x79\x9e\x86\x85\x4d\xc7\xe4\x4b\x47\x6a\x3d\x81\x62\x50\ + \\xcf\x62\xa1\xf2\x5b\x8d\x26\x46\xfc\x88\x83\xa0\xc1\xc7\xb6\xa3\ + \\x7f\x15\x24\xc3\x69\xcb\x74\x92\x47\x84\x8a\x0b\x56\x92\xb2\x85\ + \\x09\x5b\xbf\x00\xad\x19\x48\x9d\x14\x62\xb1\x74\x23\x82\x0e\x00\ + \\x58\x42\x8d\x2a\x0c\x55\xf5\xea\x1d\xad\xf4\x3e\x23\x3f\x70\x61\ + \\x33\x72\xf0\x92\x8d\x93\x7e\x41\xd6\x5f\xec\xf1\x6c\x22\x3b\xdb\ + \\x7c\xde\x37\x59\xcb\xee\x74\x60\x40\x85\xf2\xa7\xce\x77\x32\x6e\ + \\xa6\x07\x80\x84\x19\xf8\x50\x9e\xe8\xef\xd8\x55\x61\xd9\x97\x35\ + \\xa9\x69\xa7\xaa\xc5\x0c\x06\xc2\x5a\x04\xab\xfc\x80\x0b\xca\xdc\ + \\x9e\x44\x7a\x2e\xc3\x45\x34\x84\xfd\xd5\x67\x05\x0e\x1e\x9e\xc9\ + \\xdb\x73\xdb\xd3\x10\x55\x88\xcd\x67\x5f\xda\x79\xe3\x67\x43\x40\ + \\xc5\xc4\x34\x65\x71\x3e\x38\xd8\x3d\x28\xf8\x9e\xf1\x6d\xff\x20\ + \\x15\x3e\x21\xe7\x8f\xb0\x3d\x4a\xe6\xe3\x9f\x2b\xdb\x83\xad\xf7\ + \\xe9\x3d\x5a\x68\x94\x81\x40\xf7\xf6\x4c\x26\x1c\x94\x69\x29\x34\ + \\x41\x15\x20\xf7\x76\x02\xd4\xf7\xbc\xf4\x6b\x2e\xd4\xa2\x00\x68\ + \\xd4\x08\x24\x71\x33\x20\xf4\x6a\x43\xb7\xd4\xb7\x50\x00\x61\xaf\ + \\x1e\x39\xf6\x2e\x97\x24\x45\x46\x14\x21\x4f\x74\xbf\x8b\x88\x40\ + \\x4d\x95\xfc\x1d\x96\xb5\x91\xaf\x70\xf4\xdd\xd3\x66\xa0\x2f\x45\ + \\xbf\xbc\x09\xec\x03\xbd\x97\x85\x7f\xac\x6d\xd0\x31\xcb\x85\x04\ + \\x96\xeb\x27\xb3\x55\xfd\x39\x41\xda\x25\x47\xe6\xab\xca\x0a\x9a\ + \\x28\x50\x78\x25\x53\x04\x29\xf4\x0a\x2c\x86\xda\xe9\xb6\x6d\xfb\ + \\x68\xdc\x14\x62\xd7\x48\x69\x00\x68\x0e\xc0\xa4\x27\xa1\x8d\xee\ + \\x4f\x3f\xfe\xa2\xe8\x87\xad\x8c\xb5\x8c\xe0\x06\x7a\xf4\xd6\xb6\ + \\xaa\xce\x1e\x7c\xd3\x37\x5f\xec\xce\x78\xa3\x99\x40\x6b\x2a\x42\ + \\x20\xfe\x9e\x35\xd9\xf3\x85\xb9\xee\x39\xd7\xab\x3b\x12\x4e\x8b\ + \\x1d\xc9\xfa\xf7\x4b\x6d\x18\x56\x26\xa3\x66\x31\xea\xe3\x97\xb2\ + \\x3a\x6e\xfa\x74\xdd\x5b\x43\x32\x68\x41\xe7\xf7\xca\x78\x20\xfb\ + \\xfb\x0a\xf5\x4e\xd8\xfe\xb3\x97\x45\x40\x56\xac\xba\x48\x95\x27\ + \\x55\x53\x3a\x3a\x20\x83\x8d\x87\xfe\x6b\xa9\xb7\xd0\x96\x95\x4b\ + \\x55\xa8\x67\xbc\xa1\x15\x9a\x58\xcc\xa9\x29\x63\x99\xe1\xdb\x33\ + \\xa6\x2a\x4a\x56\x3f\x31\x25\xf9\x5e\xf4\x7e\x1c\x90\x29\x31\x7c\ + \\xfd\xf8\xe8\x02\x04\x27\x2f\x70\x80\xbb\x15\x5c\x05\x28\x2c\xe3\ + \\x95\xc1\x15\x48\xe4\xc6\x6d\x22\x48\xc1\x13\x3f\xc7\x0f\x86\xdc\ + \\x07\xf9\xc9\xee\x41\x04\x1f\x0f\x40\x47\x79\xa4\x5d\x88\x6e\x17\ + \\x32\x5f\x51\xeb\xd5\x9b\xc0\xd1\xf2\xbc\xc1\x8f\x41\x11\x35\x64\ + \\x25\x7b\x78\x34\x60\x2a\x9c\x60\xdf\xf8\xe8\xa3\x1f\x63\x6c\x1b\ + \\x0e\x12\xb4\xc2\x02\xe1\x32\x9e\xaf\x66\x4f\xd1\xca\xd1\x81\x15\ + \\x6b\x23\x95\xe0\x33\x3e\x92\xe1\x3b\x24\x0b\x62\xee\xbe\xb9\x22\ + \\x85\xb2\xa2\x0e\xe6\xba\x0d\x99\xde\x72\x0c\x8c\x2d\xa2\xf7\x28\ + \\xd0\x12\x78\x45\x95\xb7\x94\xfd\x64\x7d\x08\x62\xe7\xcc\xf5\xf0\ + \\x54\x49\xa3\x6f\x87\x7d\x48\xfa\xc3\x9d\xfd\x27\xf3\x3e\x8d\x1e\ + \\x0a\x47\x63\x41\x99\x2e\xff\x74\x3a\x6f\x6e\xab\xf4\xf8\xfd\x37\ + \\xa8\x12\xdc\x60\xa1\xeb\xdd\xf8\x99\x1b\xe1\x4c\xdb\x6e\x6b\x0d\ + \\xc6\x7b\x55\x10\x6d\x67\x2c\x37\x27\x65\xd4\x3b\xdc\xd0\xe8\x04\ + \\xf1\x29\x0d\xc7\xcc\x00\xff\xa3\xb5\x39\x0f\x92\x69\x0f\xed\x0b\ + \\x66\x7b\x9f\xfb\xce\xdb\x7d\x9c\xa0\x91\xcf\x0b\xd9\x15\x5e\xa3\ + \\xbb\x13\x2f\x88\x51\x5b\xad\x24\x7b\x94\x79\xbf\x76\x3b\xd6\xeb\ + \\x37\x39\x2e\xb3\xcc\x11\x59\x79\x80\x26\xe2\x97\xf4\x2e\x31\x2d\ + \\x68\x42\xad\xa7\xc6\x6a\x2b\x3b\x12\x75\x4c\xcc\x78\x2e\xf1\x1c\ + \\x6a\x12\x42\x37\xb7\x92\x51\xe7\x06\xa1\xbb\xe6\x4b\xfb\x63\x50\ + \\x1a\x6b\x10\x18\x11\xca\xed\xfa\x3d\x25\xbd\xd8\xe2\xe1\xc3\xc9\ + \\x44\x42\x16\x59\x0a\x12\x13\x86\xd9\x0c\xec\x6e\xd5\xab\xea\x2a\ + \\x64\xaf\x67\x4e\xda\x86\xa8\x5f\xbe\xbf\xe9\x88\x64\xe4\xc3\xfe\ + \\x9d\xbc\x80\x57\xf0\xf7\xc0\x86\x60\x78\x7b\xf8\x60\x03\x60\x4d\ + \\xd1\xfd\x83\x46\xf6\x38\x1f\xb0\x77\x45\xae\x04\xd7\x36\xfc\xcc\ + \\x83\x42\x6b\x33\xf0\x1e\xab\x71\xb0\x80\x41\x87\x3c\x00\x5e\x5f\ + \\x77\xa0\x57\xbe\xbd\xe8\xae\x24\x55\x46\x42\x99\xbf\x58\x2e\x61\ + \\x4e\x58\xf4\x8f\xf2\xdd\xfd\xa2\xf4\x74\xef\x38\x87\x89\xbd\xc2\ + \\x53\x66\xf9\xc3\xc8\xb3\x8e\x74\xb4\x75\xf2\x55\x46\xfc\xd9\xb9\ + \\x7a\xeb\x26\x61\x8b\x1d\xdf\x84\x84\x6a\x0e\x79\x91\x5f\x95\xe2\ + \\x46\x6e\x59\x8e\x20\xb4\x57\x70\x8c\xd5\x55\x91\xc9\x02\xde\x4c\ + \\xb9\x0b\xac\xe1\xbb\x82\x05\xd0\x11\xa8\x62\x48\x75\x74\xa9\x9e\ + \\xb7\x7f\x19\xb6\xe0\xa9\xdc\x09\x66\x2d\x09\xa1\xc4\x32\x46\x33\ + \\xe8\x5a\x1f\x02\x09\xf0\xbe\x8c\x4a\x99\xa0\x25\x1d\x6e\xfe\x10\ + \\x1a\xb9\x3d\x1d\x0b\xa5\xa4\xdf\xa1\x86\xf2\x0f\x28\x68\xf1\x69\ + \\xdc\xb7\xda\x83\x57\x39\x06\xfe\xa1\xe2\xce\x9b\x4f\xcd\x7f\x52\ + \\x50\x11\x5e\x01\xa7\x06\x83\xfa\xa0\x02\xb5\xc4\x0d\xe6\xd0\x27\ + \\x9a\xf8\x8c\x27\x77\x3f\x86\x41\xc3\x60\x4c\x06\x61\xa8\x06\xb5\ + \\xf0\x17\x7a\x28\xc0\xf5\x86\xe0\x00\x60\x58\xaa\x30\xdc\x7d\x62\ + \\x11\xe6\x9e\xd7\x23\x38\xea\x63\x53\xc2\xdd\x94\xc2\xc2\x16\x34\ + \\xbb\xcb\xee\x56\x90\xbc\xb6\xde\xeb\xfc\x7d\xa1\xce\x59\x1d\x76\ + \\x6f\x05\xe4\x09\x4b\x7c\x01\x88\x39\x72\x0a\x3d\x7c\x92\x7c\x24\ + \\x86\xe3\x72\x5f\x72\x4d\x9d\xb9\x1a\xc1\x5b\xb4\xd3\x9e\xb8\xfc\ + \\xed\x54\x55\x78\x08\xfc\xa5\xb5\xd8\x3d\x7c\xd3\x4d\xad\x0f\xc4\ + \\x1e\x50\xef\x5e\xb1\x61\xe6\xf8\xa2\x85\x14\xd9\x6c\x51\x13\x3c\ + \\x6f\xd5\xc7\xe7\x56\xe1\x4e\xc4\x36\x2a\xbf\xce\xdd\xc6\xc8\x37\ + \\xd7\x9a\x32\x34\x92\x63\x82\x12\x67\x0e\xfa\x8e\x40\x60\x00\xe0\ + \\x3a\x39\xce\x37\xd3\xfa\xf5\xcf\xab\xc2\x77\x37\x5a\xc5\x2d\x1b\ + \\x5c\xb0\x67\x9e\x4f\xa3\x37\x42\xd3\x82\x27\x40\x99\xbc\x9b\xbe\ + \\xd5\x11\x8e\x9d\xbf\x0f\x73\x15\xd6\x2d\x1c\x7e\xc7\x00\xc4\x7b\ + \\xb7\x8c\x1b\x6b\x21\xa1\x90\x45\xb2\x6e\xb1\xbe\x6a\x36\x6e\xb4\ + \\x57\x48\xab\x2f\xbc\x94\x6e\x79\xc6\xa3\x76\xd2\x65\x49\xc2\xc8\ + \\x53\x0f\xf8\xee\x46\x8d\xde\x7d\xd5\x73\x0a\x1d\x4c\xd0\x4d\xc6\ + \\x29\x39\xbb\xdb\xa9\xba\x46\x50\xac\x95\x26\xe8\xbe\x5e\xe3\x04\ + \\xa1\xfa\xd5\xf0\x6a\x2d\x51\x9a\x63\xef\x8c\xe2\x9a\x86\xee\x22\ + \\xc0\x89\xc2\xb8\x43\x24\x2e\xf6\xa5\x1e\x03\xaa\x9c\xf2\xd0\xa4\ + \\x83\xc0\x61\xba\x9b\xe9\x6a\x4d\x8f\xe5\x15\x50\xba\x64\x5b\xd6\ + \\x28\x26\xa2\xf9\xa7\x3a\x3a\xe1\x4b\xa9\x95\x86\xef\x55\x62\xe9\ + \\xc7\x2f\xef\xd3\xf7\x52\xf7\xda\x3f\x04\x6f\x69\x77\xfa\x0a\x59\ + \\x80\xe4\xa9\x15\x87\xb0\x86\x01\x9b\x09\xe6\xad\x3b\x3e\xe5\x93\ + \\xe9\x90\xfd\x5a\x9e\x34\xd7\x97\x2c\xf0\xb7\xd9\x02\x2b\x8b\x51\ + \\x96\xd5\xac\x3a\x01\x7d\xa6\x7d\xd1\xcf\x3e\xd6\x7c\x7d\x2d\x28\ + \\x1f\x9f\x25\xcf\xad\xf2\xb8\x9b\x5a\xd6\xb4\x72\x5a\x88\xf5\x4c\ + \\xe0\x29\xac\x71\xe0\x19\xa5\xe6\x47\xb0\xac\xfd\xed\x93\xfa\x9b\ + \\xe8\xd3\xc4\x8d\x28\x3b\x57\xcc\xf8\xd5\x66\x29\x79\x13\x2e\x28\ + \\x78\x5f\x01\x91\xed\x75\x60\x55\xf7\x96\x0e\x44\xe3\xd3\x5e\x8c\ + \\x15\x05\x6d\xd4\x88\xf4\x6d\xba\x03\xa1\x61\x25\x05\x64\xf0\xbd\ + \\xc3\xeb\x9e\x15\x3c\x90\x57\xa2\x97\x27\x1a\xec\xa9\x3a\x07\x2a\ + \\x1b\x3f\x6d\x9b\x1e\x63\x21\xf5\xf5\x9c\x66\xfb\x26\xdc\xf3\x19\ + \\x75\x33\xd9\x28\xb1\x55\xfd\xf5\x03\x56\x34\x82\x8a\xba\x3c\xbb\ + \\x28\x51\x77\x11\xc2\x0a\xd9\xf8\xab\xcc\x51\x67\xcc\xad\x92\x5f\ + \\x4d\xe8\x17\x51\x38\x30\xdc\x8e\x37\x9d\x58\x62\x93\x20\xf9\x91\ + \\xea\x7a\x90\xc2\xfb\x3e\x7b\xce\x51\x21\xce\x64\x77\x4f\xbe\x32\ + \\xa8\xb6\xe3\x7e\xc3\x29\x3d\x46\x48\xde\x53\x69\x64\x13\xe6\x80\ + \\xa2\xae\x08\x10\xdd\x6d\xb2\x24\x69\x85\x2d\xfd\x09\x07\x21\x66\ + \\xb3\x9a\x46\x0a\x64\x45\xc0\xdd\x58\x6c\xde\xcf\x1c\x20\xc8\xae\ + \\x5b\xbe\xf7\xdd\x1b\x58\x8d\x40\xcc\xd2\x01\x7f\x6b\xb4\xe3\xbb\ + \\xdd\xa2\x6a\x7e\x3a\x59\xff\x45\x3e\x35\x0a\x44\xbc\xb4\xcd\xd5\ + \\x72\xea\xce\xa8\xfa\x64\x84\xbb\x8d\x66\x12\xae\xbf\x3c\x6f\x47\ + \\xd2\x9b\xe4\x63\x54\x2f\x5d\x9e\xae\xc2\x77\x1b\xf6\x4e\x63\x70\ + \\x74\x0e\x0d\x8d\xe7\x5b\x13\x57\xf8\x72\x16\x71\xaf\x53\x7d\x5d\ + \\x40\x40\xcb\x08\x4e\xb4\xe2\xcc\x34\xd2\x46\x6a\x01\x15\xaf\x84\ + \\xe1\xb0\x04\x28\x95\x98\x3a\x1d\x06\xb8\x9f\xb4\xce\x6e\xa0\x48\ + \\x6f\x3f\x3b\x82\x35\x20\xab\x82\x01\x1a\x1d\x4b\x27\x72\x27\xf8\ + \\x61\x15\x60\xb1\xe7\x93\x3f\xdc\xbb\x3a\x79\x2b\x34\x45\x25\xbd\ + \\xa0\x88\x39\xe1\x51\xce\x79\x4b\x2f\x32\xc9\xb7\xa0\x1f\xba\xc9\ + \\xe0\x1c\xc8\x7e\xbc\xc7\xd1\xf6\xcf\x01\x11\xc3\xa1\xe8\xaa\xc7\ + \\x1a\x90\x87\x49\xd4\x4f\xbd\x9a\xd0\xda\xde\xcb\xd5\x0a\xda\x38\ + \\x03\x39\xc3\x2a\xc6\x91\x36\x67\x8d\xf9\x31\x7c\xe0\xb1\x2b\x4f\ + \\xf7\x9e\x59\xb7\x43\xf5\xbb\x3a\xf2\xd5\x19\xff\x27\xd9\x45\x9c\ + \\xbf\x97\x22\x2c\x15\xe6\xfc\x2a\x0f\x91\xfc\x71\x9b\x94\x15\x25\ + \\xfa\xe5\x93\x61\xce\xb6\x9c\xeb\xc2\xa8\x64\x59\x12\xba\xa8\xd1\ + \\xb6\xc1\x07\x5e\xe3\x05\x6a\x0c\x10\xd2\x50\x65\xcb\x03\xa4\x42\ + \\xe0\xec\x6e\x0e\x16\x98\xdb\x3b\x4c\x98\xa0\xbe\x32\x78\xe9\x64\ + \\x9f\x1f\x95\x32\xe0\xd3\x92\xdf\xd3\xa0\x34\x2b\x89\x71\xf2\x1e\ + \\x1b\x0a\x74\x41\x4b\xa3\x34\x8c\xc5\xbe\x71\x20\xc3\x76\x32\xd8\ + \\xdf\x35\x9f\x8d\x9b\x99\x2f\x2e\xe6\x0b\x6f\x47\x0f\xe3\xf1\x1d\ + \\xe5\x4c\xda\x54\x1e\xda\xd8\x91\xce\x62\x79\xcf\xcd\x3e\x7e\x6f\ + \\x16\x18\xb1\x66\xfd\x2c\x1d\x05\x84\x8f\xd2\xc5\xf6\xfb\x22\x99\ + \\xf5\x23\xf3\x57\xa6\x32\x76\x23\x93\xa8\x35\x31\x56\xcc\xcd\x02\ + \\xac\xf0\x81\x62\x5a\x75\xeb\xb5\x6e\x16\x36\x97\x88\xd2\x73\xcc\ + \\xde\x96\x62\x92\x81\xb9\x49\xd0\x4c\x50\x90\x1b\x71\xc6\x56\x14\ + \\xe6\xc6\xc7\xbd\x32\x7a\x14\x0a\x45\xe1\xd0\x06\xc3\xf2\x7b\x9a\ + \\xc9\xaa\x53\xfd\x62\xa8\x0f\x00\xbb\x25\xbf\xe2\x35\xbd\xd2\xf6\ + \\x71\x12\x69\x05\xb2\x04\x02\x22\xb6\xcb\xcf\x7c\xcd\x76\x9c\x2b\ + \\x53\x11\x3e\xc0\x16\x40\xe3\xd3\x38\xab\xbd\x60\x25\x47\xad\xf0\ + \\xba\x38\x20\x9c\xf7\x46\xce\x76\x77\xaf\xa1\xc5\x20\x75\x60\x60\ + \\x85\xcb\xfe\x4e\x8a\xe8\x8d\xd8\x7a\xaa\xf9\xb0\x4c\xf9\xaa\x7e\ + \\x19\x48\xc2\x5c\x02\xfb\x8a\x8c\x01\xc3\x6a\xe4\xd6\xeb\xe1\xf9\ + \\x90\xd4\xf8\x69\xa6\x5c\xde\xa0\x3f\x09\x25\x2d\xc2\x08\xe6\x9f\ + \\xb7\x4e\x61\x32\xce\x77\xe2\x5b\x57\x8f\xdf\xe3\x3a\xc3\x72\xe6\ + \"# diff --git a/bundled/Crypto/Cipher/Blowfish/Primitive.hs b/bundled/Crypto/Cipher/Blowfish/Primitive.hs new file mode 100644 index 0000000..8ce7cbe --- /dev/null +++ b/bundled/Crypto/Cipher/Blowfish/Primitive.hs @@ -0,0 +1,258 @@ +-- | +-- Module : Crypto.Cipher.Blowfish.Primitive +-- License : BSD-style +-- Stability : experimental +-- Portability : Good + +-- Rewritten by Vincent Hanquez (c) 2015 +-- Lars Petersen (c) 2018 +-- +-- Original code: +-- Crypto.Cipher.Blowfish.Primitive, copyright (c) 2012 Stijn van Drongelen +-- based on: BlowfishAux.hs (C) 2002 HardCore SoftWare, Doug Hoyte +-- (as found in Crypto-4.2.4) +{-# LANGUAGE BangPatterns #-} +module Crypto.Cipher.Blowfish.Primitive + ( Context + , initBlowfish + , encrypt + , decrypt + , KeySchedule + , createKeySchedule + , freezeKeySchedule + , expandKey + , expandKeyWithSalt + , cipherBlockMutable + ) where + +import Control.Monad (when) +import Data.Bits +import Data.Memory.Endian +import Data.Word + +import Crypto.Cipher.Blowfish.Box +import Crypto.Error +import Crypto.Internal.ByteArray (ByteArray, ByteArrayAccess) +import qualified Crypto.Internal.ByteArray as B +import Crypto.Internal.Compat +import Crypto.Internal.Imports +import Crypto.Internal.WordArray + +newtype Context = Context Array32 + +instance NFData Context where + rnf a = a `seq` () + +-- | Initialize a new Blowfish context from a key. +-- +-- key needs to be between 0 and 448 bits. +initBlowfish :: ByteArrayAccess key => key -> CryptoFailable Context +initBlowfish key + | B.length key > (448 `div` 8) = CryptoFailed CryptoError_KeySizeInvalid + | otherwise = CryptoPassed $ unsafeDoIO $ do + ks <- createKeySchedule + expandKey ks key + freezeKeySchedule ks + +-- | Get an immutable Blowfish context by freezing a mutable key schedule. +freezeKeySchedule :: KeySchedule -> IO Context +freezeKeySchedule (KeySchedule ma) = Context `fmap` mutableArray32Freeze ma + +expandKey :: (ByteArrayAccess key) => KeySchedule -> key -> IO () +expandKey ks@(KeySchedule ma) key = do + when (B.length key > 0) $ iterKeyStream key 0 0 $ \i l r a0 a1 cont-> do + mutableArrayWriteXor32 ma i l + mutableArrayWriteXor32 ma (i + 1) r + when (i + 2 < 18) (cont a0 a1) + loop 0 0 0 + where + loop i l r = do + n <- cipherBlockMutable ks (fromIntegral l `shiftL` 32 .|. fromIntegral r) + let nl = fromIntegral (n `shiftR` 32) + nr = fromIntegral (n .&. 0xffffffff) + mutableArrayWrite32 ma i nl + mutableArrayWrite32 ma (i + 1) nr + when (i < 18 + 1024) (loop (i + 2) nl nr) + +expandKeyWithSalt :: (ByteArrayAccess key, ByteArrayAccess salt) + => KeySchedule + -> key + -> salt + -> IO () +expandKeyWithSalt ks key salt + | B.length salt == 16 = expandKeyWithSalt128 ks key (fromBE $ B.toW64BE salt 0) (fromBE $ B.toW64BE salt 8) + | otherwise = expandKeyWithSaltAny ks key salt + +expandKeyWithSaltAny :: (ByteArrayAccess key, ByteArrayAccess salt) + => KeySchedule -- ^ The key schedule + -> key -- ^ The key + -> salt -- ^ The salt + -> IO () +expandKeyWithSaltAny ks@(KeySchedule ma) key salt = do + when (B.length key > 0) $ iterKeyStream key 0 0 $ \i l r a0 a1 cont-> do + mutableArrayWriteXor32 ma i l + mutableArrayWriteXor32 ma (i + 1) r + when (i + 2 < 18) (cont a0 a1) + -- Go through the entire key schedule overwriting the P-Array and S-Boxes + when (B.length salt > 0) $ iterKeyStream salt 0 0 $ \i l r a0 a1 cont-> do + let l' = xor l a0 + let r' = xor r a1 + n <- cipherBlockMutable ks (fromIntegral l' `shiftL` 32 .|. fromIntegral r') + let nl = fromIntegral (n `shiftR` 32) + nr = fromIntegral (n .&. 0xffffffff) + mutableArrayWrite32 ma i nl + mutableArrayWrite32 ma (i + 1) nr + when (i + 2 < 18 + 1024) (cont nl nr) + +expandKeyWithSalt128 :: ByteArrayAccess ba + => KeySchedule -- ^ The key schedule + -> ba -- ^ The key + -> Word64 -- ^ First word of the salt + -> Word64 -- ^ Second word of the salt + -> IO () +expandKeyWithSalt128 ks@(KeySchedule ma) key salt1 salt2 = do + when (B.length key > 0) $ iterKeyStream key 0 0 $ \i l r a0 a1 cont-> do + mutableArrayWriteXor32 ma i l + mutableArrayWriteXor32 ma (i + 1) r + when (i + 2 < 18) (cont a0 a1) + -- Go through the entire key schedule overwriting the P-Array and S-Boxes + loop 0 salt1 salt1 salt2 + where + loop i input slt1 slt2 + | i == 1042 = return () + | otherwise = do + n <- cipherBlockMutable ks input + let nl = fromIntegral (n `shiftR` 32) + nr = fromIntegral (n .&. 0xffffffff) + mutableArrayWrite32 ma i nl + mutableArrayWrite32 ma (i+1) nr + loop (i+2) (n `xor` slt2) slt2 slt1 + +-- | Encrypt blocks +-- +-- Input need to be a multiple of 8 bytes +encrypt :: ByteArray ba => Context -> ba -> ba +encrypt ctx ba + | B.length ba == 0 = B.empty + | B.length ba `mod` 8 /= 0 = error "invalid data length" + | otherwise = B.mapAsWord64 (cipherBlock ctx False) ba + +-- | Decrypt blocks +-- +-- Input need to be a multiple of 8 bytes +decrypt :: ByteArray ba => Context -> ba -> ba +decrypt ctx ba + | B.length ba == 0 = B.empty + | B.length ba `mod` 8 /= 0 = error "invalid data length" + | otherwise = B.mapAsWord64 (cipherBlock ctx True) ba + +-- | Encrypt or decrypt a single block of 64 bits. +-- +-- The inverse argument decides whether to encrypt or decrypt. +cipherBlock :: Context -> Bool -> Word64 -> Word64 +cipherBlock (Context ar) inverse input = doRound input 0 + where + -- | Transform the input over 16 rounds + doRound :: Word64 -> Int -> Word64 + doRound !i roundIndex + | roundIndex == 16 = + let final = (fromIntegral (p 16) `shiftL` 32) .|. fromIntegral (p 17) + in rotateL (i `xor` final) 32 + | otherwise = + let newr = fromIntegral (i `shiftR` 32) `xor` p roundIndex + newi = ((i `shiftL` 32) `xor` f newr) .|. fromIntegral newr + in doRound newi (roundIndex+1) + + -- | The Blowfish Feistel function F + f :: Word32 -> Word64 + f t = let a = s0 (0xff .&. (t `shiftR` 24)) + b = s1 (0xff .&. (t `shiftR` 16)) + c = s2 (0xff .&. (t `shiftR` 8)) + d = s3 (0xff .&. t) + in fromIntegral (((a + b) `xor` c) + d) `shiftL` 32 + + -- | S-Box arrays, each containing 256 32-bit words + -- The first 18 words contain the P-Array of subkeys + s0, s1, s2, s3 :: Word32 -> Word32 + s0 i = arrayRead32 ar (fromIntegral i + 18) + s1 i = arrayRead32 ar (fromIntegral i + 274) + s2 i = arrayRead32 ar (fromIntegral i + 530) + s3 i = arrayRead32 ar (fromIntegral i + 786) + p :: Int -> Word32 + p i | inverse = arrayRead32 ar (17 - i) + | otherwise = arrayRead32 ar i + +-- | Blowfish encrypt a Word using the current state of the key schedule +cipherBlockMutable :: KeySchedule -> Word64 -> IO Word64 +cipherBlockMutable (KeySchedule ma) input = doRound input 0 + where + -- | Transform the input over 16 rounds + doRound !i roundIndex + | roundIndex == 16 = do + pVal1 <- mutableArrayRead32 ma 16 + pVal2 <- mutableArrayRead32 ma 17 + let final = (fromIntegral pVal1 `shiftL` 32) .|. fromIntegral pVal2 + return $ rotateL (i `xor` final) 32 + | otherwise = do + pVal <- mutableArrayRead32 ma roundIndex + let newr = fromIntegral (i `shiftR` 32) `xor` pVal + newr' <- f newr + let newi = ((i `shiftL` 32) `xor` newr') .|. fromIntegral newr + doRound newi (roundIndex+1) + + -- | The Blowfish Feistel function F + f :: Word32 -> IO Word64 + f t = do + a <- s0 (0xff .&. (t `shiftR` 24)) + b <- s1 (0xff .&. (t `shiftR` 16)) + c <- s2 (0xff .&. (t `shiftR` 8)) + d <- s3 (0xff .&. t) + return (fromIntegral (((a + b) `xor` c) + d) `shiftL` 32) + + -- | S-Box arrays, each containing 256 32-bit words + -- The first 18 words contain the P-Array of subkeys + s0, s1, s2, s3 :: Word32 -> IO Word32 + s0 i = mutableArrayRead32 ma (fromIntegral i + 18) + s1 i = mutableArrayRead32 ma (fromIntegral i + 274) + s2 i = mutableArrayRead32 ma (fromIntegral i + 530) + s3 i = mutableArrayRead32 ma (fromIntegral i + 786) + +iterKeyStream :: (ByteArrayAccess x) + => x + -> Word32 + -> Word32 + -> (Int -> Word32 -> Word32 -> Word32 -> Word32 -> (Word32 -> Word32 -> IO ()) -> IO ()) + -> IO () +iterKeyStream x a0 a1 g = f 0 0 a0 a1 + where + len = B.length x + -- Avoiding the modulo operation when interating over the ring + -- buffer is assumed to be more efficient here. All other + -- implementations do this, too. The branch prediction shall prefer + -- the branch with the increment. + n j = if j + 1 >= len then 0 else j + 1 + f i j0 b0 b1 = g i l r b0 b1 (f (i + 2) j8) + where + j1 = n j0 + j2 = n j1 + j3 = n j2 + j4 = n j3 + j5 = n j4 + j6 = n j5 + j7 = n j6 + j8 = n j7 + x0 = fromIntegral (B.index x j0) + x1 = fromIntegral (B.index x j1) + x2 = fromIntegral (B.index x j2) + x3 = fromIntegral (B.index x j3) + x4 = fromIntegral (B.index x j4) + x5 = fromIntegral (B.index x j5) + x6 = fromIntegral (B.index x j6) + x7 = fromIntegral (B.index x j7) + l = shiftL x0 24 .|. shiftL x1 16 .|. shiftL x2 8 .|. x3 + r = shiftL x4 24 .|. shiftL x5 16 .|. shiftL x6 8 .|. x7 +{-# INLINE iterKeyStream #-} +-- Benchmarking shows that GHC considers this function too big to inline +-- although forcing inlining causes an actual improvement. +-- It is assumed that all function calls (especially the continuation) +-- collapse into a tight loop after inlining. diff --git a/bundled/Crypto/Cipher/CAST5.hs b/bundled/Crypto/Cipher/CAST5.hs new file mode 100644 index 0000000..d0e357c --- /dev/null +++ b/bundled/Crypto/Cipher/CAST5.hs @@ -0,0 +1,43 @@ +-- | +-- Module : Crypto.Cipher.CAST5 +-- License : BSD-style +-- Maintainer : Olivier Chéron +-- Stability : stable +-- Portability : good +-- +module Crypto.Cipher.CAST5 + ( CAST5 + ) where + +import Crypto.Error +import Crypto.Cipher.Types +import Crypto.Cipher.CAST5.Primitive +import Crypto.Internal.ByteArray (ByteArrayAccess) +import qualified Crypto.Internal.ByteArray as B + +-- | CAST5 block cipher (also known as CAST-128). Key is between +-- 40 and 128 bits. +newtype CAST5 = CAST5 Key + +instance Cipher CAST5 where + cipherName _ = "CAST5" + cipherKeySize _ = KeySizeRange 5 16 + cipherInit = initCAST5 + +instance BlockCipher CAST5 where + blockSize _ = 8 + ecbEncrypt (CAST5 k) = B.mapAsWord64 (encrypt k) + ecbDecrypt (CAST5 k) = B.mapAsWord64 (decrypt k) + +initCAST5 :: ByteArrayAccess key => key -> CryptoFailable CAST5 +initCAST5 bs + | len < 5 = CryptoFailed CryptoError_KeySizeInvalid + | len < 16 = CryptoPassed (CAST5 $ buildKey short padded) + | len == 16 = CryptoPassed (CAST5 $ buildKey False bs) + | otherwise = CryptoFailed CryptoError_KeySizeInvalid + where + len = B.length bs + short = len <= 10 + + padded :: B.Bytes + padded = B.convert bs `B.append` B.replicate (16 - len) 0 diff --git a/bundled/Crypto/Cipher/CAST5/Primitive.hs b/bundled/Crypto/Cipher/CAST5/Primitive.hs new file mode 100644 index 0000000..092e726 --- /dev/null +++ b/bundled/Crypto/Cipher/CAST5/Primitive.hs @@ -0,0 +1,573 @@ +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Crypto.Cipher.CAST5.Primitive +-- License : BSD-style +-- +-- Haskell implementation of the CAST-128 Encryption Algorithm +-- +----------------------------------------------------------------------------- + + +module Crypto.Cipher.CAST5.Primitive + ( encrypt + , decrypt + , Key() + , buildKey + ) where + +import Control.Monad (void, (>=>)) + +import Data.Bits +import Data.Memory.Endian +import Data.Word + +import Crypto.Internal.ByteArray (ByteArrayAccess) +import qualified Crypto.Internal.ByteArray as B +import Crypto.Internal.WordArray + + +-- Data Types + +data P = P {-# UNPACK #-} !Word32 -- left word + {-# UNPACK #-} !Word32 -- right word + +data Q = Q {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 + {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 + +-- | All subkeys for 12 or 16 rounds +data Key = K12 {-# UNPACK #-} !Array32 -- [ km1, kr1, km2, kr2, ..., km12, kr12 ] + | K16 {-# UNPACK #-} !Array32 -- [ km1, kr1, km2, kr2, ..., km16, kr16 ] + + +-- Big-endian Transformations + +decomp64 :: Word64 -> P +decomp64 x = P (fromIntegral (x `shiftR` 32)) (fromIntegral x) + +comp64 :: P -> Word64 +comp64 (P l r) = (fromIntegral l `shiftL` 32) .|. fromIntegral r + +decomp32 :: Word32 -> (Word8, Word8, Word8, Word8) +decomp32 x = + let a = fromIntegral (x `shiftR` 24) + b = fromIntegral (x `shiftR` 16) + c = fromIntegral (x `shiftR` 8) + d = fromIntegral x + in (a, b, c, d) + + +-- Encryption + +-- | Encrypts a block using the specified key +encrypt :: Key -> Word64 -> Word64 +encrypt k = comp64 . cast_enc k . decomp64 + +cast_enc :: Key -> P -> P +cast_enc (K12 a) (P l0 r0) = P r12 r11 + where + r1 = type1 a 0 l0 r0 + r2 = type2 a 2 r0 r1 + r3 = type3 a 4 r1 r2 + r4 = type1 a 6 r2 r3 + r5 = type2 a 8 r3 r4 + r6 = type3 a 10 r4 r5 + r7 = type1 a 12 r5 r6 + r8 = type2 a 14 r6 r7 + r9 = type3 a 16 r7 r8 + r10 = type1 a 18 r8 r9 + r11 = type2 a 20 r9 r10 + r12 = type3 a 22 r10 r11 + +cast_enc (K16 a) p = P r16 r15 + where + P r12 r11 = cast_enc (K12 a) p + + r13 = type1 a 24 r11 r12 + r14 = type2 a 26 r12 r13 + r15 = type3 a 28 r13 r14 + r16 = type1 a 30 r14 r15 + +-- Decryption + +-- | Decrypts a block using the specified key +decrypt :: Key -> Word64 -> Word64 +decrypt k = comp64 . cast_dec k . decomp64 + +cast_dec :: Key -> P -> P +cast_dec (K12 a) (P r12 r11) = P l0 r0 + where + r10 = type3 a 22 r12 r11 + r9 = type2 a 20 r11 r10 + r8 = type1 a 18 r10 r9 + r7 = type3 a 16 r9 r8 + r6 = type2 a 14 r8 r7 + r5 = type1 a 12 r7 r6 + r4 = type3 a 10 r6 r5 + r3 = type2 a 8 r5 r4 + r2 = type1 a 6 r4 r3 + r1 = type3 a 4 r3 r2 + r0 = type2 a 2 r2 r1 + l0 = type1 a 0 r1 r0 + +cast_dec (K16 a) (P r16 r15) = cast_dec (K12 a) (P r12 r11) + where + r14 = type1 a 30 r16 r15 + r13 = type3 a 28 r15 r14 + r12 = type2 a 26 r14 r13 + r11 = type1 a 24 r13 r12 + + +-- Non-Identical Rounds + +type1 :: Array32 -> Int -> Word32 -> Word32 -> Word32 +type1 arr idx l r = + let km = arrayRead32 arr idx + kr = arrayRead32 arr (idx + 1) + j = (km + r) `rotateL` fromIntegral kr + (ja, jb, jc, jd) = decomp32 j + in l `xor` (((sbox_s1 ja `xor` sbox_s2 jb) - sbox_s3 jc) + sbox_s4 jd) + +type2 :: Array32 -> Int -> Word32 -> Word32 -> Word32 +type2 arr idx l r = + let km = arrayRead32 arr idx + kr = arrayRead32 arr (idx + 1) + j = (km `xor` r) `rotateL` fromIntegral kr + (ja, jb, jc, jd) = decomp32 j + in l `xor` (((sbox_s1 ja - sbox_s2 jb) + sbox_s3 jc) `xor` sbox_s4 jd) + +type3 :: Array32 -> Int -> Word32 -> Word32 -> Word32 +type3 arr idx l r = + let km = arrayRead32 arr idx + kr = arrayRead32 arr (idx + 1) + j = (km - r) `rotateL` fromIntegral kr + (ja, jb, jc, jd) = decomp32 j + in l `xor` (((sbox_s1 ja + sbox_s2 jb) `xor` sbox_s3 jc) - sbox_s4 jd) + + +-- Key Schedule + +-- | Precompute "masking" and "rotation" subkeys +buildKey :: ByteArrayAccess key + => Bool -- ^ @True@ for short keys that only need 12 rounds + -> key -- ^ Input key padded to 16 bytes + -> Key -- ^ Output data structure +buildKey isShort key = + let P x0123 x4567 = decomp64 (fromBE $ B.toW64BE key 0) + P x89AB xCDEF = decomp64 (fromBE $ B.toW64BE key 8) + in keySchedule isShort (Q x0123 x4567 x89AB xCDEF) + +keySchedule :: Bool -> Q -> Key +keySchedule isShort x + | isShort = K12 $ allocArray32AndFreeze 24 $ \ma -> + void (steps123 ma 0 x >>= skip4 >>= steps123 ma 1) + + | otherwise = K16 $ allocArray32AndFreeze 32 $ \ma -> + void (steps123 ma 0 x >>= step4 ma 24 >>= steps123 ma 1 >>= step4 ma 25) + + where + sbox_s56785 a b c d e = sbox_s5 a `xor` sbox_s6 b `xor` sbox_s7 c `xor` sbox_s8 d `xor` sbox_s5 e + sbox_s56786 a b c d e = sbox_s5 a `xor` sbox_s6 b `xor` sbox_s7 c `xor` sbox_s8 d `xor` sbox_s6 e + sbox_s56787 a b c d e = sbox_s5 a `xor` sbox_s6 b `xor` sbox_s7 c `xor` sbox_s8 d `xor` sbox_s7 e + sbox_s56788 a b c d e = sbox_s5 a `xor` sbox_s6 b `xor` sbox_s7 c `xor` sbox_s8 d `xor` sbox_s8 e + + steps123 ma off = step1 ma off >=> step2 ma (off + 8) >=> step3 ma (off + 16) + + step1 :: MutableArray32 -> Int -> Q -> IO Q + step1 ma off (Q x0123 x4567 x89AB xCDEF) = do + let (x8, x9, xA, xB) = decomp32 x89AB + (xC, xD, xE, xF) = decomp32 xCDEF + + z0123 = x0123 `xor` sbox_s56787 xD xF xC xE x8 + z4567 = x89AB `xor` sbox_s56788 z0 z2 z1 z3 xA + z89AB = xCDEF `xor` sbox_s56785 z7 z6 z5 z4 x9 + zCDEF = x4567 `xor` sbox_s56786 zA z9 zB z8 xB + + (z0, z1, z2, z3) = decomp32 z0123 + (z4, z5, z6, z7) = decomp32 z4567 + (z8, z9, zA, zB) = decomp32 z89AB + (zC, zD, zE, zF) = decomp32 zCDEF + + mutableArrayWrite32 ma (off + 0) $ sbox_s56785 z8 z9 z7 z6 z2 + mutableArrayWrite32 ma (off + 2) $ sbox_s56786 zA zB z5 z4 z6 + mutableArrayWrite32 ma (off + 4) $ sbox_s56787 zC zD z3 z2 z9 + mutableArrayWrite32 ma (off + 6) $ sbox_s56788 zE zF z1 z0 zC + return (Q z0123 z4567 z89AB zCDEF) + + step2 :: MutableArray32 -> Int -> Q -> IO Q + step2 ma off (Q z0123 z4567 z89AB zCDEF) = do + let (z0, z1, z2, z3) = decomp32 z0123 + (z4, z5, z6, z7) = decomp32 z4567 + + x0123 = z89AB `xor` sbox_s56787 z5 z7 z4 z6 z0 + x4567 = z0123 `xor` sbox_s56788 x0 x2 x1 x3 z2 + x89AB = z4567 `xor` sbox_s56785 x7 x6 x5 x4 z1 + xCDEF = zCDEF `xor` sbox_s56786 xA x9 xB x8 z3 + + (x0, x1, x2, x3) = decomp32 x0123 + (x4, x5, x6, x7) = decomp32 x4567 + (x8, x9, xA, xB) = decomp32 x89AB + (xC, xD, xE, xF) = decomp32 xCDEF + + mutableArrayWrite32 ma (off + 0) $ sbox_s56785 x3 x2 xC xD x8 + mutableArrayWrite32 ma (off + 2) $ sbox_s56786 x1 x0 xE xF xD + mutableArrayWrite32 ma (off + 4) $ sbox_s56787 x7 x6 x8 x9 x3 + mutableArrayWrite32 ma (off + 6) $ sbox_s56788 x5 x4 xA xB x7 + return (Q x0123 x4567 x89AB xCDEF) + + step3 :: MutableArray32 -> Int -> Q -> IO Q + step3 ma off (Q x0123 x4567 x89AB xCDEF) = do + let (x8, x9, xA, xB) = decomp32 x89AB + (xC, xD, xE, xF) = decomp32 xCDEF + + z0123 = x0123 `xor` sbox_s56787 xD xF xC xE x8 + z4567 = x89AB `xor` sbox_s56788 z0 z2 z1 z3 xA + z89AB = xCDEF `xor` sbox_s56785 z7 z6 z5 z4 x9 + zCDEF = x4567 `xor` sbox_s56786 zA z9 zB z8 xB + + (z0, z1, z2, z3) = decomp32 z0123 + (z4, z5, z6, z7) = decomp32 z4567 + (z8, z9, zA, zB) = decomp32 z89AB + (zC, zD, zE, zF) = decomp32 zCDEF + + mutableArrayWrite32 ma (off + 0) $ sbox_s56785 z3 z2 zC zD z9 + mutableArrayWrite32 ma (off + 2) $ sbox_s56786 z1 z0 zE zF zC + mutableArrayWrite32 ma (off + 4) $ sbox_s56787 z7 z6 z8 z9 z2 + mutableArrayWrite32 ma (off + 6) $ sbox_s56788 z5 z4 zA zB z6 + return (Q z0123 z4567 z89AB zCDEF) + + step4 :: MutableArray32 -> Int -> Q -> IO Q + step4 ma off (Q z0123 z4567 z89AB zCDEF) = do + let (z0, z1, z2, z3) = decomp32 z0123 + (z4, z5, z6, z7) = decomp32 z4567 + + x0123 = z89AB `xor` sbox_s56787 z5 z7 z4 z6 z0 + x4567 = z0123 `xor` sbox_s56788 x0 x2 x1 x3 z2 + x89AB = z4567 `xor` sbox_s56785 x7 x6 x5 x4 z1 + xCDEF = zCDEF `xor` sbox_s56786 xA x9 xB x8 z3 + + (x0, x1, x2, x3) = decomp32 x0123 + (x4, x5, x6, x7) = decomp32 x4567 + (x8, x9, xA, xB) = decomp32 x89AB + (xC, xD, xE, xF) = decomp32 xCDEF + + mutableArrayWrite32 ma (off + 0) $ sbox_s56785 x8 x9 x7 x6 x3 + mutableArrayWrite32 ma (off + 2) $ sbox_s56786 xA xB x5 x4 x7 + mutableArrayWrite32 ma (off + 4) $ sbox_s56787 xC xD x3 x2 x8 + mutableArrayWrite32 ma (off + 6) $ sbox_s56788 xE xF x1 x0 xD + return (Q x0123 x4567 x89AB xCDEF) + + skip4 :: Q -> IO Q + skip4 (Q z0123 z4567 z89AB zCDEF) = do + let (z0, z1, z2, z3) = decomp32 z0123 + (z4, z5, z6, z7) = decomp32 z4567 + + x0123 = z89AB `xor` sbox_s56787 z5 z7 z4 z6 z0 + x4567 = z0123 `xor` sbox_s56788 x0 x2 x1 x3 z2 + x89AB = z4567 `xor` sbox_s56785 x7 x6 x5 x4 z1 + xCDEF = zCDEF `xor` sbox_s56786 xA x9 xB x8 z3 + + (x0, x1, x2, x3) = decomp32 x0123 + (x4, x5, x6, x7) = decomp32 x4567 + (x8, x9, xA, xB) = decomp32 x89AB + + return (Q x0123 x4567 x89AB xCDEF) + +-- S-Boxes + +sbox_s1 :: Word8 -> Word32 +sbox_s1 i = arrayRead32 t (fromIntegral i) + where + t = array32FromAddrBE 256 + "\x30\xfb\x40\xd4\x9f\xa0\xff\x0b\x6b\xec\xcd\x2f\x3f\x25\x8c\x7a\x1e\x21\x3f\x2f\x9c\x00\x4d\xd3\x60\x03\xe5\x40\xcf\x9f\xc9\x49\ + \\xbf\xd4\xaf\x27\x88\xbb\xbd\xb5\xe2\x03\x40\x90\x98\xd0\x96\x75\x6e\x63\xa0\xe0\x15\xc3\x61\xd2\xc2\xe7\x66\x1d\x22\xd4\xff\x8e\ + \\x28\x68\x3b\x6f\xc0\x7f\xd0\x59\xff\x23\x79\xc8\x77\x5f\x50\xe2\x43\xc3\x40\xd3\xdf\x2f\x86\x56\x88\x7c\xa4\x1a\xa2\xd2\xbd\x2d\ + \\xa1\xc9\xe0\xd6\x34\x6c\x48\x19\x61\xb7\x6d\x87\x22\x54\x0f\x2f\x2a\xbe\x32\xe1\xaa\x54\x16\x6b\x22\x56\x8e\x3a\xa2\xd3\x41\xd0\ + \\x66\xdb\x40\xc8\xa7\x84\x39\x2f\x00\x4d\xff\x2f\x2d\xb9\xd2\xde\x97\x94\x3f\xac\x4a\x97\xc1\xd8\x52\x76\x44\xb7\xb5\xf4\x37\xa7\ + \\xb8\x2c\xba\xef\xd7\x51\xd1\x59\x6f\xf7\xf0\xed\x5a\x09\x7a\x1f\x82\x7b\x68\xd0\x90\xec\xf5\x2e\x22\xb0\xc0\x54\xbc\x8e\x59\x35\ + \\x4b\x6d\x2f\x7f\x50\xbb\x64\xa2\xd2\x66\x49\x10\xbe\xe5\x81\x2d\xb7\x33\x22\x90\xe9\x3b\x15\x9f\xb4\x8e\xe4\x11\x4b\xff\x34\x5d\ + \\xfd\x45\xc2\x40\xad\x31\x97\x3f\xc4\xf6\xd0\x2e\x55\xfc\x81\x65\xd5\xb1\xca\xad\xa1\xac\x2d\xae\xa2\xd4\xb7\x6d\xc1\x9b\x0c\x50\ + \\x88\x22\x40\xf2\x0c\x6e\x4f\x38\xa4\xe4\xbf\xd7\x4f\x5b\xa2\x72\x56\x4c\x1d\x2f\xc5\x9c\x53\x19\xb9\x49\xe3\x54\xb0\x46\x69\xfe\ + \\xb1\xb6\xab\x8a\xc7\x13\x58\xdd\x63\x85\xc5\x45\x11\x0f\x93\x5d\x57\x53\x8a\xd5\x6a\x39\x04\x93\xe6\x3d\x37\xe0\x2a\x54\xf6\xb3\ + \\x3a\x78\x7d\x5f\x62\x76\xa0\xb5\x19\xa6\xfc\xdf\x7a\x42\x20\x6a\x29\xf9\xd4\xd5\xf6\x1b\x18\x91\xbb\x72\x27\x5e\xaa\x50\x81\x67\ + \\x38\x90\x10\x91\xc6\xb5\x05\xeb\x84\xc7\xcb\x8c\x2a\xd7\x5a\x0f\x87\x4a\x14\x27\xa2\xd1\x93\x6b\x2a\xd2\x86\xaf\xaa\x56\xd2\x91\ + \\xd7\x89\x43\x60\x42\x5c\x75\x0d\x93\xb3\x9e\x26\x18\x71\x84\xc9\x6c\x00\xb3\x2d\x73\xe2\xbb\x14\xa0\xbe\xbc\x3c\x54\x62\x37\x79\ + \\x64\x45\x9e\xab\x3f\x32\x8b\x82\x77\x18\xcf\x82\x59\xa2\xce\xa6\x04\xee\x00\x2e\x89\xfe\x78\xe6\x3f\xab\x09\x50\x32\x5f\xf6\xc2\ + \\x81\x38\x3f\x05\x69\x63\xc5\xc8\x76\xcb\x5a\xd6\xd4\x99\x74\xc9\xca\x18\x0d\xcf\x38\x07\x82\xd5\xc7\xfa\x5c\xf6\x8a\xc3\x15\x11\ + \\x35\xe7\x9e\x13\x47\xda\x91\xd0\xf4\x0f\x90\x86\xa7\xe2\x41\x9e\x31\x36\x62\x41\x05\x1e\xf4\x95\xaa\x57\x3b\x04\x4a\x80\x5d\x8d\ + \\x54\x83\x00\xd0\x00\x32\x2a\x3c\xbf\x64\xcd\xdf\xba\x57\xa6\x8e\x75\xc6\x37\x2b\x50\xaf\xd3\x41\xa7\xc1\x32\x75\x91\x5a\x0b\xf5\ + \\x6b\x54\xbf\xab\x2b\x0b\x14\x26\xab\x4c\xc9\xd7\x44\x9c\xcd\x82\xf7\xfb\xf2\x65\xab\x85\xc5\xf3\x1b\x55\xdb\x94\xaa\xd4\xe3\x24\ + \\xcf\xa4\xbd\x3f\x2d\xea\xa3\xe2\x9e\x20\x4d\x02\xc8\xbd\x25\xac\xea\xdf\x55\xb3\xd5\xbd\x9e\x98\xe3\x12\x31\xb2\x2a\xd5\xad\x6c\ + \\x95\x43\x29\xde\xad\xbe\x45\x28\xd8\x71\x0f\x69\xaa\x51\xc9\x0f\xaa\x78\x6b\xf6\x22\x51\x3f\x1e\xaa\x51\xa7\x9b\x2a\xd3\x44\xcc\ + \\x7b\x5a\x41\xf0\xd3\x7c\xfb\xad\x1b\x06\x95\x05\x41\xec\xe4\x91\xb4\xc3\x32\xe6\x03\x22\x68\xd4\xc9\x60\x0a\xcc\xce\x38\x7e\x6d\ + \\xbf\x6b\xb1\x6c\x6a\x70\xfb\x78\x0d\x03\xd9\xc9\xd4\xdf\x39\xde\xe0\x10\x63\xda\x47\x36\xf4\x64\x5a\xd3\x28\xd8\xb3\x47\xcc\x96\ + \\x75\xbb\x0f\xc3\x98\x51\x1b\xfb\x4f\xfb\xcc\x35\xb5\x8b\xcf\x6a\xe1\x1f\x0a\xbc\xbf\xc5\xfe\x4a\xa7\x0a\xec\x10\xac\x39\x57\x0a\ + \\x3f\x04\x44\x2f\x61\x88\xb1\x53\xe0\x39\x7a\x2e\x57\x27\xcb\x79\x9c\xeb\x41\x8f\x1c\xac\xd6\x8d\x2a\xd3\x7c\x96\x01\x75\xcb\x9d\ + \\xc6\x9d\xff\x09\xc7\x5b\x65\xf0\xd9\xdb\x40\xd8\xec\x0e\x77\x79\x47\x44\xea\xd4\xb1\x1c\x32\x74\xdd\x24\xcb\x9e\x7e\x1c\x54\xbd\ + \\xf0\x11\x44\xf9\xd2\x24\x0e\xb1\x96\x75\xb3\xfd\xa3\xac\x37\x55\xd4\x7c\x27\xaf\x51\xc8\x5f\x4d\x56\x90\x75\x96\xa5\xbb\x15\xe6\ + \\x58\x03\x04\xf0\xca\x04\x2c\xf1\x01\x1a\x37\xea\x8d\xbf\xaa\xdb\x35\xba\x3e\x4a\x35\x26\xff\xa0\xc3\x7b\x4d\x09\xbc\x30\x6e\xd9\ + \\x98\xa5\x26\x66\x56\x48\xf7\x25\xff\x5e\x56\x9d\x0c\xed\x63\xd0\x7c\x63\xb2\xcf\x70\x0b\x45\xe1\xd5\xea\x50\xf1\x85\xa9\x28\x72\ + \\xaf\x1f\xbd\xa7\xd4\x23\x48\x70\xa7\x87\x0b\xf3\x2d\x3b\x4d\x79\x42\xe0\x41\x98\x0c\xd0\xed\xe7\x26\x47\x0d\xb8\xf8\x81\x81\x4c\ + \\x47\x4d\x6a\xd7\x7c\x0c\x5e\x5c\xd1\x23\x19\x59\x38\x1b\x72\x98\xf5\xd2\xf4\xdb\xab\x83\x86\x53\x6e\x2f\x1e\x23\x83\x71\x9c\x9e\ + \\xbd\x91\xe0\x46\x9a\x56\x45\x6e\xdc\x39\x20\x0c\x20\xc8\xc5\x71\x96\x2b\xda\x1c\xe1\xe6\x96\xff\xb1\x41\xab\x08\x7c\xca\x89\xb9\ + \\x1a\x69\xe7\x83\x02\xcc\x48\x43\xa2\xf7\xc5\x79\x42\x9e\xf4\x7d\x42\x7b\x16\x9c\x5a\xc9\xf0\x49\xdd\x8f\x0f\x00\x5c\x81\x65\xbf"# + +sbox_s2 :: Word8 -> Word32 +sbox_s2 i = arrayRead32 t (fromIntegral i) + where + t = array32FromAddrBE 256 + "\x1f\x20\x10\x94\xef\x0b\xa7\x5b\x69\xe3\xcf\x7e\x39\x3f\x43\x80\xfe\x61\xcf\x7a\xee\xc5\x20\x7a\x55\x88\x9c\x94\x72\xfc\x06\x51\ + \\xad\xa7\xef\x79\x4e\x1d\x72\x35\xd5\x5a\x63\xce\xde\x04\x36\xba\x99\xc4\x30\xef\x5f\x0c\x07\x94\x18\xdc\xdb\x7d\xa1\xd6\xef\xf3\ + \\xa0\xb5\x2f\x7b\x59\xe8\x36\x05\xee\x15\xb0\x94\xe9\xff\xd9\x09\xdc\x44\x00\x86\xef\x94\x44\x59\xba\x83\xcc\xb3\xe0\xc3\xcd\xfb\ + \\xd1\xda\x41\x81\x3b\x09\x2a\xb1\xf9\x97\xf1\xc1\xa5\xe6\xcf\x7b\x01\x42\x0d\xdb\xe4\xe7\xef\x5b\x25\xa1\xff\x41\xe1\x80\xf8\x06\ + \\x1f\xc4\x10\x80\x17\x9b\xee\x7a\xd3\x7a\xc6\xa9\xfe\x58\x30\xa4\x98\xde\x8b\x7f\x77\xe8\x3f\x4e\x79\x92\x92\x69\x24\xfa\x9f\x7b\ + \\xe1\x13\xc8\x5b\xac\xc4\x00\x83\xd7\x50\x35\x25\xf7\xea\x61\x5f\x62\x14\x31\x54\x0d\x55\x4b\x63\x5d\x68\x11\x21\xc8\x66\xc3\x59\ + \\x3d\x63\xcf\x73\xce\xe2\x34\xc0\xd4\xd8\x7e\x87\x5c\x67\x2b\x21\x07\x1f\x61\x81\x39\xf7\x62\x7f\x36\x1e\x30\x84\xe4\xeb\x57\x3b\ + \\x60\x2f\x64\xa4\xd6\x3a\xcd\x9c\x1b\xbc\x46\x35\x9e\x81\x03\x2d\x27\x01\xf5\x0c\x99\x84\x7a\xb4\xa0\xe3\xdf\x79\xba\x6c\xf3\x8c\ + \\x10\x84\x30\x94\x25\x37\xa9\x5e\xf4\x6f\x6f\xfe\xa1\xff\x3b\x1f\x20\x8c\xfb\x6a\x8f\x45\x8c\x74\xd9\xe0\xa2\x27\x4e\xc7\x3a\x34\ + \\xfc\x88\x4f\x69\x3e\x4d\xe8\xdf\xef\x0e\x00\x88\x35\x59\x64\x8d\x8a\x45\x38\x8c\x1d\x80\x43\x66\x72\x1d\x9b\xfd\xa5\x86\x84\xbb\ + \\xe8\x25\x63\x33\x84\x4e\x82\x12\x12\x8d\x80\x98\xfe\xd3\x3f\xb4\xce\x28\x0a\xe1\x27\xe1\x9b\xa5\xd5\xa6\xc2\x52\xe4\x97\x54\xbd\ + \\xc5\xd6\x55\xdd\xeb\x66\x70\x64\x77\x84\x0b\x4d\xa1\xb6\xa8\x01\x84\xdb\x26\xa9\xe0\xb5\x67\x14\x21\xf0\x43\xb7\xe5\xd0\x58\x60\ + \\x54\xf0\x30\x84\x06\x6f\xf4\x72\xa3\x1a\xa1\x53\xda\xdc\x47\x55\xb5\x62\x5d\xbf\x68\x56\x1b\xe6\x83\xca\x6b\x94\x2d\x6e\xd2\x3b\ + \\xec\xcf\x01\xdb\xa6\xd3\xd0\xba\xb6\x80\x3d\x5c\xaf\x77\xa7\x09\x33\xb4\xa3\x4c\x39\x7b\xc8\xd6\x5e\xe2\x2b\x95\x5f\x0e\x53\x04\ + \\x81\xed\x6f\x61\x20\xe7\x43\x64\xb4\x5e\x13\x78\xde\x18\x63\x9b\x88\x1c\xa1\x22\xb9\x67\x26\xd1\x80\x49\xa7\xe8\x22\xb7\xda\x7b\ + \\x5e\x55\x2d\x25\x52\x72\xd2\x37\x79\xd2\x95\x1c\xc6\x0d\x89\x4c\x48\x8c\xb4\x02\x1b\xa4\xfe\x5b\xa4\xb0\x9f\x6b\x1c\xa8\x15\xcf\ + \\xa2\x0c\x30\x05\x88\x71\xdf\x63\xb9\xde\x2f\xcb\x0c\xc6\xc9\xe9\x0b\xee\xff\x53\xe3\x21\x45\x17\xb4\x54\x28\x35\x9f\x63\x29\x3c\ + \\xee\x41\xe7\x29\x6e\x1d\x2d\x7c\x50\x04\x52\x86\x1e\x66\x85\xf3\xf3\x34\x01\xc6\x30\xa2\x2c\x95\x31\xa7\x08\x50\x60\x93\x0f\x13\ + \\x73\xf9\x84\x17\xa1\x26\x98\x59\xec\x64\x5c\x44\x52\xc8\x77\xa9\xcd\xff\x33\xa6\xa0\x2b\x17\x41\x7c\xba\xd9\xa2\x21\x80\x03\x6f\ + \\x50\xd9\x9c\x08\xcb\x3f\x48\x61\xc2\x6b\xd7\x65\x64\xa3\xf6\xab\x80\x34\x26\x76\x25\xa7\x5e\x7b\xe4\xe6\xd1\xfc\x20\xc7\x10\xe6\ + \\xcd\xf0\xb6\x80\x17\x84\x4d\x3b\x31\xee\xf8\x4d\x7e\x08\x24\xe4\x2c\xcb\x49\xeb\x84\x6a\x3b\xae\x8f\xf7\x78\x88\xee\x5d\x60\xf6\ + \\x7a\xf7\x56\x73\x2f\xdd\x5c\xdb\xa1\x16\x31\xc1\x30\xf6\x6f\x43\xb3\xfa\xec\x54\x15\x7f\xd7\xfa\xef\x85\x79\xcc\xd1\x52\xde\x58\ + \\xdb\x2f\xfd\x5e\x8f\x32\xce\x19\x30\x6a\xf9\x7a\x02\xf0\x3e\xf8\x99\x31\x9a\xd5\xc2\x42\xfa\x0f\xa7\xe3\xeb\xb0\xc6\x8e\x49\x06\ + \\xb8\xda\x23\x0c\x80\x82\x30\x28\xdc\xde\xf3\xc8\xd3\x5f\xb1\x71\x08\x8a\x1b\xc8\xbe\xc0\xc5\x60\x61\xa3\xc9\xe8\xbc\xa8\xf5\x4d\ + \\xc7\x2f\xef\xfa\x22\x82\x2e\x99\x82\xc5\x70\xb4\xd8\xd9\x4e\x89\x8b\x1c\x34\xbc\x30\x1e\x16\xe6\x27\x3b\xe9\x79\xb0\xff\xea\xa6\ + \\x61\xd9\xb8\xc6\x00\xb2\x48\x69\xb7\xff\xce\x3f\x08\xdc\x28\x3b\x43\xda\xf6\x5a\xf7\xe1\x97\x98\x76\x19\xb7\x2f\x8f\x1c\x9b\xa4\ + \\xdc\x86\x37\xa0\x16\xa7\xd3\xb1\x9f\xc3\x93\xb7\xa7\x13\x6e\xeb\xc6\xbc\xc6\x3e\x1a\x51\x37\x42\xef\x68\x28\xbc\x52\x03\x65\xd6\ + \\x2d\x6a\x77\xab\x35\x27\xed\x4b\x82\x1f\xd2\x16\x09\x5c\x6e\x2e\xdb\x92\xf2\xfb\x5e\xea\x29\xcb\x14\x58\x92\xf5\x91\x58\x4f\x7f\ + \\x54\x83\x69\x7b\x26\x67\xa8\xcc\x85\x19\x60\x48\x8c\x4b\xac\xea\x83\x38\x60\xd4\x0d\x23\xe0\xf9\x6c\x38\x7e\x8a\x0a\xe6\xd2\x49\ + \\xb2\x84\x60\x0c\xd8\x35\x73\x1d\xdc\xb1\xc6\x47\xac\x4c\x56\xea\x3e\xbd\x81\xb3\x23\x0e\xab\xb0\x64\x38\xbc\x87\xf0\xb5\xb1\xfa\ + \\x8f\x5e\xa2\xb3\xfc\x18\x46\x42\x0a\x03\x6b\x7a\x4f\xb0\x89\xbd\x64\x9d\xa5\x89\xa3\x45\x41\x5e\x5c\x03\x83\x23\x3e\x5d\x3b\xb9\ + \\x43\xd7\x95\x72\x7e\x6d\xd0\x7c\x06\xdf\xdf\x1e\x6c\x6c\xc4\xef\x71\x60\xa5\x39\x73\xbf\xbe\x70\x83\x87\x76\x05\x45\x23\xec\xf1"# + +sbox_s3 :: Word8 -> Word32 +sbox_s3 i = arrayRead32 t (fromIntegral i) + where + t = array32FromAddrBE 256 + "\x8d\xef\xc2\x40\x25\xfa\x5d\x9f\xeb\x90\x3d\xbf\xe8\x10\xc9\x07\x47\x60\x7f\xff\x36\x9f\xe4\x4b\x8c\x1f\xc6\x44\xae\xce\xca\x90\ + \\xbe\xb1\xf9\xbf\xee\xfb\xca\xea\xe8\xcf\x19\x50\x51\xdf\x07\xae\x92\x0e\x88\x06\xf0\xad\x05\x48\xe1\x3c\x8d\x83\x92\x70\x10\xd5\ + \\x11\x10\x7d\x9f\x07\x64\x7d\xb9\xb2\xe3\xe4\xd4\x3d\x4f\x28\x5e\xb9\xaf\xa8\x20\xfa\xde\x82\xe0\xa0\x67\x26\x8b\x82\x72\x79\x2e\ + \\x55\x3f\xb2\xc0\x48\x9a\xe2\x2b\xd4\xef\x97\x94\x12\x5e\x3f\xbc\x21\xff\xfc\xee\x82\x5b\x1b\xfd\x92\x55\xc5\xed\x12\x57\xa2\x40\ + \\x4e\x1a\x83\x02\xba\xe0\x7f\xff\x52\x82\x46\xe7\x8e\x57\x14\x0e\x33\x73\xf7\xbf\x8c\x9f\x81\x88\xa6\xfc\x4e\xe8\xc9\x82\xb5\xa5\ + \\xa8\xc0\x1d\xb7\x57\x9f\xc2\x64\x67\x09\x4f\x31\xf2\xbd\x3f\x5f\x40\xff\xf7\xc1\x1f\xb7\x8d\xfc\x8e\x6b\xd2\xc1\x43\x7b\xe5\x9b\ + \\x99\xb0\x3d\xbf\xb5\xdb\xc6\x4b\x63\x8d\xc0\xe6\x55\x81\x9d\x99\xa1\x97\xc8\x1c\x4a\x01\x2d\x6e\xc5\x88\x4a\x28\xcc\xc3\x6f\x71\ + \\xb8\x43\xc2\x13\x6c\x07\x43\xf1\x83\x09\x89\x3c\x0f\xed\xdd\x5f\x2f\x7f\xe8\x50\xd7\xc0\x7f\x7e\x02\x50\x7f\xbf\x5a\xfb\x9a\x04\ + \\xa7\x47\xd2\xd0\x16\x51\x19\x2e\xaf\x70\xbf\x3e\x58\xc3\x13\x80\x5f\x98\x30\x2e\x72\x7c\xc3\xc4\x0a\x0f\xb4\x02\x0f\x7f\xef\x82\ + \\x8c\x96\xfd\xad\x5d\x2c\x2a\xae\x8e\xe9\x9a\x49\x50\xda\x88\xb8\x84\x27\xf4\xa0\x1e\xac\x57\x90\x79\x6f\xb4\x49\x82\x52\xdc\x15\ + \\xef\xbd\x7d\x9b\xa6\x72\x59\x7d\xad\xa8\x40\xd8\x45\xf5\x45\x04\xfa\x5d\x74\x03\xe8\x3e\xc3\x05\x4f\x91\x75\x1a\x92\x56\x69\xc2\ + \\x23\xef\xe9\x41\xa9\x03\xf1\x2e\x60\x27\x0d\xf2\x02\x76\xe4\xb6\x94\xfd\x65\x74\x92\x79\x85\xb2\x82\x76\xdb\xcb\x02\x77\x81\x76\ + \\xf8\xaf\x91\x8d\x4e\x48\xf7\x9e\x8f\x61\x6d\xdf\xe2\x9d\x84\x0e\x84\x2f\x7d\x83\x34\x0c\xe5\xc8\x96\xbb\xb6\x82\x93\xb4\xb1\x48\ + \\xef\x30\x3c\xab\x98\x4f\xaf\x28\x77\x9f\xaf\x9b\x92\xdc\x56\x0d\x22\x4d\x1e\x20\x84\x37\xaa\x88\x7d\x29\xdc\x96\x27\x56\xd3\xdc\ + \\x8b\x90\x7c\xee\xb5\x1f\xd2\x40\xe7\xc0\x7c\xe3\xe5\x66\xb4\xa1\xc3\xe9\x61\x5e\x3c\xf8\x20\x9d\x60\x94\xd1\xe3\xcd\x9c\xa3\x41\ + \\x5c\x76\x46\x0e\x00\xea\x98\x3b\xd4\xd6\x78\x81\xfd\x47\x57\x2c\xf7\x6c\xed\xd9\xbd\xa8\x22\x9c\x12\x7d\xad\xaa\x43\x8a\x07\x4e\ + \\x1f\x97\xc0\x90\x08\x1b\xdb\x8a\x93\xa0\x7e\xbe\xb9\x38\xca\x15\x97\xb0\x3c\xff\x3d\xc2\xc0\xf8\x8d\x1a\xb2\xec\x64\x38\x0e\x51\ + \\x68\xcc\x7b\xfb\xd9\x0f\x27\x88\x12\x49\x01\x81\x5d\xe5\xff\xd4\xdd\x7e\xf8\x6a\x76\xa2\xe2\x14\xb9\xa4\x03\x68\x92\x5d\x95\x8f\ + \\x4b\x39\xff\xfa\xba\x39\xae\xe9\xa4\xff\xd3\x0b\xfa\xf7\x93\x3b\x6d\x49\x86\x23\x19\x3c\xbc\xfa\x27\x62\x75\x45\x82\x5c\xf4\x7a\ + \\x61\xbd\x8b\xa0\xd1\x1e\x42\xd1\xce\xad\x04\xf4\x12\x7e\xa3\x92\x10\x42\x8d\xb7\x82\x72\xa9\x72\x92\x70\xc4\xa8\x12\x7d\xe5\x0b\ + \\x28\x5b\xa1\xc8\x3c\x62\xf4\x4f\x35\xc0\xea\xa5\xe8\x05\xd2\x31\x42\x89\x29\xfb\xb4\xfc\xdf\x82\x4f\xb6\x6a\x53\x0e\x7d\xc1\x5b\ + \\x1f\x08\x1f\xab\x10\x86\x18\xae\xfc\xfd\x08\x6d\xf9\xff\x28\x89\x69\x4b\xcc\x11\x23\x6a\x5c\xae\x12\xde\xca\x4d\x2c\x3f\x8c\xc5\ + \\xd2\xd0\x2d\xfe\xf8\xef\x58\x96\xe4\xcf\x52\xda\x95\x15\x5b\x67\x49\x4a\x48\x8c\xb9\xb6\xa8\x0c\x5c\x8f\x82\xbc\x89\xd3\x6b\x45\ + \\x3a\x60\x94\x37\xec\x00\xc9\xa9\x44\x71\x52\x53\x0a\x87\x4b\x49\xd7\x73\xbc\x40\x7c\x34\x67\x1c\x02\x71\x7e\xf6\x4f\xeb\x55\x36\ + \\xa2\xd0\x2f\xff\xd2\xbf\x60\xc4\xd4\x3f\x03\xc0\x50\xb4\xef\x6d\x07\x47\x8c\xd1\x00\x6e\x18\x88\xa2\xe5\x3f\x55\xb9\xe6\xd4\xbc\ + \\xa2\x04\x80\x16\x97\x57\x38\x33\xd7\x20\x7d\x67\xde\x0f\x8f\x3d\x72\xf8\x7b\x33\xab\xcc\x4f\x33\x76\x88\xc5\x5d\x7b\x00\xa6\xb0\ + \\x94\x7b\x00\x01\x57\x00\x75\xd2\xf9\xbb\x88\xf8\x89\x42\x01\x9e\x42\x64\xa5\xff\x85\x63\x02\xe0\x72\xdb\xd9\x2b\xee\x97\x1b\x69\ + \\x6e\xa2\x2f\xde\x5f\x08\xae\x2b\xaf\x7a\x61\x6d\xe5\xc9\x87\x67\xcf\x1f\xeb\xd2\x61\xef\xc8\xc2\xf1\xac\x25\x71\xcc\x82\x39\xc2\ + \\x67\x21\x4c\xb8\xb1\xe5\x83\xd1\xb7\xdc\x3e\x62\x7f\x10\xbd\xce\xf9\x0a\x5c\x38\x0f\xf0\x44\x3d\x60\x6e\x6d\xc6\x60\x54\x3a\x49\ + \\x57\x27\xc1\x48\x2b\xe9\x8a\x1d\x8a\xb4\x17\x38\x20\xe1\xbe\x24\xaf\x96\xda\x0f\x68\x45\x84\x25\x99\x83\x3b\xe5\x60\x0d\x45\x7d\ + \\x28\x2f\x93\x50\x83\x34\xb3\x62\xd9\x1d\x11\x20\x2b\x6d\x8d\xa0\x64\x2b\x1e\x31\x9c\x30\x5a\x00\x52\xbc\xe6\x88\x1b\x03\x58\x8a\ + \\xf7\xba\xef\xd5\x41\x42\xed\x9c\xa4\x31\x5c\x11\x83\x32\x3e\xc5\xdf\xef\x46\x36\xa1\x33\xc5\x01\xe9\xd3\x53\x1c\xee\x35\x37\x83"# + +sbox_s4 :: Word8 -> Word32 +sbox_s4 i = arrayRead32 t (fromIntegral i) + where + t = array32FromAddrBE 256 + "\x9d\xb3\x04\x20\x1f\xb6\xe9\xde\xa7\xbe\x7b\xef\xd2\x73\xa2\x98\x4a\x4f\x7b\xdb\x64\xad\x8c\x57\x85\x51\x04\x43\xfa\x02\x0e\xd1\ + \\x7e\x28\x7a\xff\xe6\x0f\xb6\x63\x09\x5f\x35\xa1\x79\xeb\xf1\x20\xfd\x05\x9d\x43\x64\x97\xb7\xb1\xf3\x64\x1f\x63\x24\x1e\x4a\xdf\ + \\x28\x14\x7f\x5f\x4f\xa2\xb8\xcd\xc9\x43\x00\x40\x0c\xc3\x22\x20\xfd\xd3\x0b\x30\xc0\xa5\x37\x4f\x1d\x2d\x00\xd9\x24\x14\x7b\x15\ + \\xee\x4d\x11\x1a\x0f\xca\x51\x67\x71\xff\x90\x4c\x2d\x19\x5f\xfe\x1a\x05\x64\x5f\x0c\x13\xfe\xfe\x08\x1b\x08\xca\x05\x17\x01\x21\ + \\x80\x53\x01\x00\xe8\x3e\x5e\xfe\xac\x9a\xf4\xf8\x7f\xe7\x27\x01\xd2\xb8\xee\x5f\x06\xdf\x42\x61\xbb\x9e\x9b\x8a\x72\x93\xea\x25\ + \\xce\x84\xff\xdf\xf5\x71\x88\x01\x3d\xd6\x4b\x04\xa2\x6f\x26\x3b\x7e\xd4\x84\x00\x54\x7e\xeb\xe6\x44\x6d\x4c\xa0\x6c\xf3\xd6\xf5\ + \\x26\x49\xab\xdf\xae\xa0\xc7\xf5\x36\x33\x8c\xc1\x50\x3f\x7e\x93\xd3\x77\x20\x61\x11\xb6\x38\xe1\x72\x50\x0e\x03\xf8\x0e\xb2\xbb\ + \\xab\xe0\x50\x2e\xec\x8d\x77\xde\x57\x97\x1e\x81\xe1\x4f\x67\x46\xc9\x33\x54\x00\x69\x20\x31\x8f\x08\x1d\xbb\x99\xff\xc3\x04\xa5\ + \\x4d\x35\x18\x05\x7f\x3d\x5c\xe3\xa6\xc8\x66\xc6\x5d\x5b\xcc\xa9\xda\xec\x6f\xea\x9f\x92\x6f\x91\x9f\x46\x22\x2f\x39\x91\x46\x7d\ + \\xa5\xbf\x6d\x8e\x11\x43\xc4\x4f\x43\x95\x83\x02\xd0\x21\x4e\xeb\x02\x20\x83\xb8\x3f\xb6\x18\x0c\x18\xf8\x93\x1e\x28\x16\x58\xe6\ + \\x26\x48\x6e\x3e\x8b\xd7\x8a\x70\x74\x77\xe4\xc1\xb5\x06\xe0\x7c\xf3\x2d\x0a\x25\x79\x09\x8b\x02\xe4\xea\xbb\x81\x28\x12\x3b\x23\ + \\x69\xde\xad\x38\x15\x74\xca\x16\xdf\x87\x1b\x62\x21\x1c\x40\xb7\xa5\x1a\x9e\xf9\x00\x14\x37\x7b\x04\x1e\x8a\xc8\x09\x11\x40\x03\ + \\xbd\x59\xe4\xd2\xe3\xd1\x56\xd5\x4f\xe8\x76\xd5\x2f\x91\xa3\x40\x55\x7b\xe8\xde\x00\xea\xe4\xa7\x0c\xe5\xc2\xec\x4d\xb4\xbb\xa6\ + \\xe7\x56\xbd\xff\xdd\x33\x69\xac\xec\x17\xb0\x35\x06\x57\x23\x27\x99\xaf\xc8\xb0\x56\xc8\xc3\x91\x6b\x65\x81\x1c\x5e\x14\x61\x19\ + \\x6e\x85\xcb\x75\xbe\x07\xc0\x02\xc2\x32\x55\x77\x89\x3f\xf4\xec\x5b\xbf\xc9\x2d\xd0\xec\x3b\x25\xb7\x80\x1a\xb7\x8d\x6d\x3b\x24\ + \\x20\xc7\x63\xef\xc3\x66\xa5\xfc\x9c\x38\x28\x80\x0a\xce\x32\x05\xaa\xc9\x54\x8a\xec\xa1\xd7\xc7\x04\x1a\xfa\x32\x1d\x16\x62\x5a\ + \\x67\x01\x90\x2c\x9b\x75\x7a\x54\x31\xd4\x77\xf7\x91\x26\xb0\x31\x36\xcc\x6f\xdb\xc7\x0b\x8b\x46\xd9\xe6\x6a\x48\x56\xe5\x5a\x79\ + \\x02\x6a\x4c\xeb\x52\x43\x7e\xff\x2f\x8f\x76\xb4\x0d\xf9\x80\xa5\x86\x74\xcd\xe3\xed\xda\x04\xeb\x17\xa9\xbe\x04\x2c\x18\xf4\xdf\ + \\xb7\x74\x7f\x9d\xab\x2a\xf7\xb4\xef\xc3\x4d\x20\x2e\x09\x6b\x7c\x17\x41\xa2\x54\xe5\xb6\xa0\x35\x21\x3d\x42\xf6\x2c\x1c\x7c\x26\ + \\x61\xc2\xf5\x0f\x65\x52\xda\xf9\xd2\xc2\x31\xf8\x25\x13\x0f\x69\xd8\x16\x7f\xa2\x04\x18\xf2\xc8\x00\x1a\x96\xa6\x0d\x15\x26\xab\ + \\x63\x31\x5c\x21\x5e\x0a\x72\xec\x49\xba\xfe\xfd\x18\x79\x08\xd9\x8d\x0d\xbd\x86\x31\x11\x70\xa7\x3e\x9b\x64\x0c\xcc\x3e\x10\xd7\ + \\xd5\xca\xd3\xb6\x0c\xae\xc3\x88\xf7\x30\x01\xe1\x6c\x72\x8a\xff\x71\xea\xe2\xa1\x1f\x9a\xf3\x6e\xcf\xcb\xd1\x2f\xc1\xde\x84\x17\ + \\xac\x07\xbe\x6b\xcb\x44\xa1\xd8\x8b\x9b\x0f\x56\x01\x39\x88\xc3\xb1\xc5\x2f\xca\xb4\xbe\x31\xcd\xd8\x78\x28\x06\x12\xa3\xa4\xe2\ + \\x6f\x7d\xe5\x32\x58\xfd\x7e\xb6\xd0\x1e\xe9\x00\x24\xad\xff\xc2\xf4\x99\x0f\xc5\x97\x11\xaa\xc5\x00\x1d\x7b\x95\x82\xe5\xe7\xd2\ + \\x10\x98\x73\xf6\x00\x61\x30\x96\xc3\x2d\x95\x21\xad\xa1\x21\xff\x29\x90\x84\x15\x7f\xbb\x97\x7f\xaf\x9e\xb3\xdb\x29\xc9\xed\x2a\ + \\x5c\xe2\xa4\x65\xa7\x30\xf3\x2c\xd0\xaa\x3f\xe8\x8a\x5c\xc0\x91\xd4\x9e\x2c\xe7\x0c\xe4\x54\xa9\xd6\x0a\xcd\x86\x01\x5f\x19\x19\ + \\x77\x07\x91\x03\xde\xa0\x3a\xf6\x78\xa8\x56\x5e\xde\xe3\x56\xdf\x21\xf0\x5c\xbe\x8b\x75\xe3\x87\xb3\xc5\x06\x51\xb8\xa5\xc3\xef\ + \\xd8\xee\xb6\xd2\xe5\x23\xbe\x77\xc2\x15\x45\x29\x2f\x69\xef\xdf\xaf\xe6\x7a\xfb\xf4\x70\xc4\xb2\xf3\xe0\xeb\x5b\xd6\xcc\x98\x76\ + \\x39\xe4\x46\x0c\x1f\xda\x85\x38\x19\x87\x83\x2f\xca\x00\x73\x67\xa9\x91\x44\xf8\x29\x6b\x29\x9e\x49\x2f\xc2\x95\x92\x66\xbe\xab\ + \\xb5\x67\x6e\x69\x9b\xd3\xdd\xda\xdf\x7e\x05\x2f\xdb\x25\x70\x1c\x1b\x5e\x51\xee\xf6\x53\x24\xe6\x6a\xfc\xe3\x6c\x03\x16\xcc\x04\ + \\x86\x44\x21\x3e\xb7\xdc\x59\xd0\x79\x65\x29\x1f\xcc\xd6\xfd\x43\x41\x82\x39\x79\x93\x2b\xcd\xf6\xb6\x57\xc3\x4d\x4e\xdf\xd2\x82\ + \\x7a\xe5\x29\x0c\x3c\xb9\x53\x6b\x85\x1e\x20\xfe\x98\x33\x55\x7e\x13\xec\xf0\xb0\xd3\xff\xb3\x72\x3f\x85\xc5\xc1\x0a\xef\x7e\xd2"# + +sbox_s5 :: Word8 -> Word32 +sbox_s5 i = arrayRead32 t (fromIntegral i) + where + t = array32FromAddrBE 256 + "\x7e\xc9\x0c\x04\x2c\x6e\x74\xb9\x9b\x0e\x66\xdf\xa6\x33\x79\x11\xb8\x6a\x7f\xff\x1d\xd3\x58\xf5\x44\xdd\x9d\x44\x17\x31\x16\x7f\ + \\x08\xfb\xf1\xfa\xe7\xf5\x11\xcc\xd2\x05\x1b\x00\x73\x5a\xba\x00\x2a\xb7\x22\xd8\x38\x63\x81\xcb\xac\xf6\x24\x3a\x69\xbe\xfd\x7a\ + \\xe6\xa2\xe7\x7f\xf0\xc7\x20\xcd\xc4\x49\x48\x16\xcc\xf5\xc1\x80\x38\x85\x16\x40\x15\xb0\xa8\x48\xe6\x8b\x18\xcb\x4c\xaa\xde\xff\ + \\x5f\x48\x0a\x01\x04\x12\xb2\xaa\x25\x98\x14\xfc\x41\xd0\xef\xe2\x4e\x40\xb4\x8d\x24\x8e\xb6\xfb\x8d\xba\x1c\xfe\x41\xa9\x9b\x02\ + \\x1a\x55\x0a\x04\xba\x8f\x65\xcb\x72\x51\xf4\xe7\x95\xa5\x17\x25\xc1\x06\xec\xd7\x97\xa5\x98\x0a\xc5\x39\xb9\xaa\x4d\x79\xfe\x6a\ + \\xf2\xf3\xf7\x63\x68\xaf\x80\x40\xed\x0c\x9e\x56\x11\xb4\x95\x8b\xe1\xeb\x5a\x88\x87\x09\xe6\xb0\xd7\xe0\x71\x56\x4e\x29\xfe\xa7\ + \\x63\x66\xe5\x2d\x02\xd1\xc0\x00\xc4\xac\x8e\x05\x93\x77\xf5\x71\x0c\x05\x37\x2a\x57\x85\x35\xf2\x22\x61\xbe\x02\xd6\x42\xa0\xc9\ + \\xdf\x13\xa2\x80\x74\xb5\x5b\xd2\x68\x21\x99\xc0\xd4\x21\xe5\xec\x53\xfb\x3c\xe8\xc8\xad\xed\xb3\x28\xa8\x7f\xc9\x3d\x95\x99\x81\ + \\x5c\x1f\xf9\x00\xfe\x38\xd3\x99\x0c\x4e\xff\x0b\x06\x24\x07\xea\xaa\x2f\x4f\xb1\x4f\xb9\x69\x76\x90\xc7\x95\x05\xb0\xa8\xa7\x74\ + \\xef\x55\xa1\xff\xe5\x9c\xa2\xc2\xa6\xb6\x2d\x27\xe6\x6a\x42\x63\xdf\x65\x00\x1f\x0e\xc5\x09\x66\xdf\xdd\x55\xbc\x29\xde\x06\x55\ + \\x91\x1e\x73\x9a\x17\xaf\x89\x75\x32\xc7\x91\x1c\x89\xf8\x94\x68\x0d\x01\xe9\x80\x52\x47\x55\xf4\x03\xb6\x3c\xc9\x0c\xc8\x44\xb2\ + \\xbc\xf3\xf0\xaa\x87\xac\x36\xe9\xe5\x3a\x74\x26\x01\xb3\xd8\x2b\x1a\x9e\x74\x49\x64\xee\x2d\x7e\xcd\xdb\xb1\xda\x01\xc9\x49\x10\ + \\xb8\x68\xbf\x80\x0d\x26\xf3\xfd\x93\x42\xed\xe7\x04\xa5\xc2\x84\x63\x67\x37\xb6\x50\xf5\xb6\x16\xf2\x47\x66\xe3\x8e\xca\x36\xc1\ + \\x13\x6e\x05\xdb\xfe\xf1\x83\x91\xfb\x88\x7a\x37\xd6\xe7\xf7\xd4\xc7\xfb\x7d\xc9\x30\x63\xfc\xdf\xb6\xf5\x89\xde\xec\x29\x41\xda\ + \\x26\xe4\x66\x95\xb7\x56\x64\x19\xf6\x54\xef\xc5\xd0\x8d\x58\xb7\x48\x92\x54\x01\xc1\xba\xcb\x7f\xe5\xff\x55\x0f\xb6\x08\x30\x49\ + \\x5b\xb5\xd0\xe8\x87\xd7\x2e\x5a\xab\x6a\x6e\xe1\x22\x3a\x66\xce\xc6\x2b\xf3\xcd\x9e\x08\x85\xf9\x68\xcb\x3e\x47\x08\x6c\x01\x0f\ + \\xa2\x1d\xe8\x20\xd1\x8b\x69\xde\xf3\xf6\x57\x77\xfa\x02\xc3\xf6\x40\x7e\xda\xc3\xcb\xb3\xd5\x50\x17\x93\x08\x4d\xb0\xd7\x0e\xba\ + \\x0a\xb3\x78\xd5\xd9\x51\xfb\x0c\xde\xd7\xda\x56\x41\x24\xbb\xe4\x94\xca\x0b\x56\x0f\x57\x55\xd1\xe0\xe1\xe5\x6e\x61\x84\xb5\xbe\ + \\x58\x0a\x24\x9f\x94\xf7\x4b\xc0\xe3\x27\x88\x8e\x9f\x7b\x55\x61\xc3\xdc\x02\x80\x05\x68\x77\x15\x64\x6c\x6b\xd7\x44\x90\x4d\xb3\ + \\x66\xb4\xf0\xa3\xc0\xf1\x64\x8a\x69\x7e\xd5\xaf\x49\xe9\x2f\xf6\x30\x9e\x37\x4f\x2c\xb6\x35\x6a\x85\x80\x85\x73\x49\x91\xf8\x40\ + \\x76\xf0\xae\x02\x08\x3b\xe8\x4d\x28\x42\x1c\x9a\x44\x48\x94\x06\x73\x6e\x4c\xb8\xc1\x09\x29\x10\x8b\xc9\x5f\xc6\x7d\x86\x9c\xf4\ + \\x13\x4f\x61\x6f\x2e\x77\x11\x8d\xb3\x1b\x2b\xe1\xaa\x90\xb4\x72\x3c\xa5\xd7\x17\x7d\x16\x1b\xba\x9c\xad\x90\x10\xaf\x46\x2b\xa2\ + \\x9f\xe4\x59\xd2\x45\xd3\x45\x59\xd9\xf2\xda\x13\xdb\xc6\x54\x87\xf3\xe4\xf9\x4e\x17\x6d\x48\x6f\x09\x7c\x13\xea\x63\x1d\xa5\xc7\ + \\x44\x5f\x73\x82\x17\x56\x83\xf4\xcd\xc6\x6a\x97\x70\xbe\x02\x88\xb3\xcd\xcf\x72\x6e\x5d\xd2\xf3\x20\x93\x60\x79\x45\x9b\x80\xa5\ + \\xbe\x60\xe2\xdb\xa9\xc2\x31\x01\xeb\xa5\x31\x5c\x22\x4e\x42\xf2\x1c\x5c\x15\x72\xf6\x72\x1b\x2c\x1a\xd2\xff\xf3\x8c\x25\x40\x4e\ + \\x32\x4e\xd7\x2f\x40\x67\xb7\xfd\x05\x23\x13\x8e\x5c\xa3\xbc\x78\xdc\x0f\xd6\x6e\x75\x92\x22\x83\x78\x4d\x6b\x17\x58\xeb\xb1\x6e\ + \\x44\x09\x4f\x85\x3f\x48\x1d\x87\xfc\xfe\xae\x7b\x77\xb5\xff\x76\x8c\x23\x02\xbf\xaa\xf4\x75\x56\x5f\x46\xb0\x2a\x2b\x09\x28\x01\ + \\x3d\x38\xf5\xf7\x0c\xa8\x1f\x36\x52\xaf\x4a\x8a\x66\xd5\xe7\xc0\xdf\x3b\x08\x74\x95\x05\x51\x10\x1b\x5a\xd7\xa8\xf6\x1e\xd5\xad\ + \\x6c\xf6\xe4\x79\x20\x75\x81\x84\xd0\xce\xfa\x65\x88\xf7\xbe\x58\x4a\x04\x68\x26\x0f\xf6\xf8\xf3\xa0\x9c\x7f\x70\x53\x46\xab\xa0\ + \\x5c\xe9\x6c\x28\xe1\x76\xed\xa3\x6b\xac\x30\x7f\x37\x68\x29\xd2\x85\x36\x0f\xa9\x17\xe3\xfe\x2a\x24\xb7\x97\x67\xf5\xa9\x6b\x20\ + \\xd6\xcd\x25\x95\x68\xff\x1e\xbf\x75\x55\x44\x2c\xf1\x9f\x06\xbe\xf9\xe0\x65\x9a\xee\xb9\x49\x1d\x34\x01\x07\x18\xbb\x30\xca\xb8\ + \\xe8\x22\xfe\x15\x88\x57\x09\x83\x75\x0e\x62\x49\xda\x62\x7e\x55\x5e\x76\xff\xa8\xb1\x53\x45\x46\x6d\x47\xde\x08\xef\xe9\xe7\xd4"# + +sbox_s6 :: Word8 -> Word32 +sbox_s6 i = arrayRead32 t (fromIntegral i) + where + t = array32FromAddrBE 256 + "\xf6\xfa\x8f\x9d\x2c\xac\x6c\xe1\x4c\xa3\x48\x67\xe2\x33\x7f\x7c\x95\xdb\x08\xe7\x01\x68\x43\xb4\xec\xed\x5c\xbc\x32\x55\x53\xac\ + \\xbf\x9f\x09\x60\xdf\xa1\xe2\xed\x83\xf0\x57\x9d\x63\xed\x86\xb9\x1a\xb6\xa6\xb8\xde\x5e\xbe\x39\xf3\x8f\xf7\x32\x89\x89\xb1\x38\ + \\x33\xf1\x49\x61\xc0\x19\x37\xbd\xf5\x06\xc6\xda\xe4\x62\x5e\x7e\xa3\x08\xea\x99\x4e\x23\xe3\x3c\x79\xcb\xd7\xcc\x48\xa1\x43\x67\ + \\xa3\x14\x96\x19\xfe\xc9\x4b\xd5\xa1\x14\x17\x4a\xea\xa0\x18\x66\xa0\x84\xdb\x2d\x09\xa8\x48\x6f\xa8\x88\x61\x4a\x29\x00\xaf\x98\ + \\x01\x66\x59\x91\xe1\x99\x28\x63\xc8\xf3\x0c\x60\x2e\x78\xef\x3c\xd0\xd5\x19\x32\xcf\x0f\xec\x14\xf7\xca\x07\xd2\xd0\xa8\x20\x72\ + \\xfd\x41\x19\x7e\x93\x05\xa6\xb0\xe8\x6b\xe3\xda\x74\xbe\xd3\xcd\x37\x2d\xa5\x3c\x4c\x7f\x44\x48\xda\xb5\xd4\x40\x6d\xba\x0e\xc3\ + \\x08\x39\x19\xa7\x9f\xba\xee\xd9\x49\xdb\xcf\xb0\x4e\x67\x0c\x53\x5c\x3d\x9c\x01\x64\xbd\xb9\x41\x2c\x0e\x63\x6a\xba\x7d\xd9\xcd\ + \\xea\x6f\x73\x88\xe7\x0b\xc7\x62\x35\xf2\x9a\xdb\x5c\x4c\xdd\x8d\xf0\xd4\x8d\x8c\xb8\x81\x53\xe2\x08\xa1\x98\x66\x1a\xe2\xea\xc8\ + \\x28\x4c\xaf\x89\xaa\x92\x82\x23\x93\x34\xbe\x53\x3b\x3a\x21\xbf\x16\x43\x4b\xe3\x9a\xea\x39\x06\xef\xe8\xc3\x6e\xf8\x90\xcd\xd9\ + \\x80\x22\x6d\xae\xc3\x40\xa4\xa3\xdf\x7e\x9c\x09\xa6\x94\xa8\x07\x5b\x7c\x5e\xcc\x22\x1d\xb3\xa6\x9a\x69\xa0\x2f\x68\x81\x8a\x54\ + \\xce\xb2\x29\x6f\x53\xc0\x84\x3a\xfe\x89\x36\x55\x25\xbf\xe6\x8a\xb4\x62\x8a\xbc\xcf\x22\x2e\xbf\x25\xac\x6f\x48\xa9\xa9\x93\x87\ + \\x53\xbd\xdb\x65\xe7\x6f\xfb\xe7\xe9\x67\xfd\x78\x0b\xa9\x35\x63\x8e\x34\x2b\xc1\xe8\xa1\x1b\xe9\x49\x80\x74\x0d\xc8\x08\x7d\xfc\ + \\x8d\xe4\xbf\x99\xa1\x11\x01\xa0\x7f\xd3\x79\x75\xda\x5a\x26\xc0\xe8\x1f\x99\x4f\x95\x28\xcd\x89\xfd\x33\x9f\xed\xb8\x78\x34\xbf\ + \\x5f\x04\x45\x6d\x22\x25\x86\x98\xc9\xc4\xc8\x3b\x2d\xc1\x56\xbe\x4f\x62\x8d\xaa\x57\xf5\x5e\xc5\xe2\x22\x0a\xbe\xd2\x91\x6e\xbf\ + \\x4e\xc7\x5b\x95\x24\xf2\xc3\xc0\x42\xd1\x5d\x99\xcd\x0d\x7f\xa0\x7b\x6e\x27\xff\xa8\xdc\x8a\xf0\x73\x45\xc1\x06\xf4\x1e\x23\x2f\ + \\x35\x16\x23\x86\xe6\xea\x89\x26\x33\x33\xb0\x94\x15\x7e\xc6\xf2\x37\x2b\x74\xaf\x69\x25\x73\xe4\xe9\xa9\xd8\x48\xf3\x16\x02\x89\ + \\x3a\x62\xef\x1d\xa7\x87\xe2\x38\xf3\xa5\xf6\x76\x74\x36\x48\x53\x20\x95\x10\x63\x45\x76\x69\x8d\xb6\xfa\xd4\x07\x59\x2a\xf9\x50\ + \\x36\xf7\x35\x23\x4c\xfb\x6e\x87\x7d\xa4\xce\xc0\x6c\x15\x2d\xaa\xcb\x03\x96\xa8\xc5\x0d\xfe\x5d\xfc\xd7\x07\xab\x09\x21\xc4\x2f\ + \\x89\xdf\xf0\xbb\x5f\xe2\xbe\x78\x44\x8f\x4f\x33\x75\x46\x13\xc9\x2b\x05\xd0\x8d\x48\xb9\xd5\x85\xdc\x04\x94\x41\xc8\x09\x8f\x9b\ + \\x7d\xed\xe7\x86\xc3\x9a\x33\x73\x42\x41\x00\x05\x6a\x09\x17\x51\x0e\xf3\xc8\xa6\x89\x00\x72\xd6\x28\x20\x76\x82\xa9\xa9\xf7\xbe\ + \\xbf\x32\x67\x9d\xd4\x5b\x5b\x75\xb3\x53\xfd\x00\xcb\xb0\xe3\x58\x83\x0f\x22\x0a\x1f\x8f\xb2\x14\xd3\x72\xcf\x08\xcc\x3c\x4a\x13\ + \\x8c\xf6\x31\x66\x06\x1c\x87\xbe\x88\xc9\x8f\x88\x60\x62\xe3\x97\x47\xcf\x8e\x7a\xb6\xc8\x52\x83\x3c\xc2\xac\xfb\x3f\xc0\x69\x76\ + \\x4e\x8f\x02\x52\x64\xd8\x31\x4d\xda\x38\x70\xe3\x1e\x66\x54\x59\xc1\x09\x08\xf0\x51\x30\x21\xa5\x6c\x5b\x68\xb7\x82\x2f\x8a\xa0\ + \\x30\x07\xcd\x3e\x74\x71\x9e\xef\xdc\x87\x26\x81\x07\x33\x40\xd4\x7e\x43\x2f\xd9\x0c\x5e\xc2\x41\x88\x09\x28\x6c\xf5\x92\xd8\x91\ + \\x08\xa9\x30\xf6\x95\x7e\xf3\x05\xb7\xfb\xff\xbd\xc2\x66\xe9\x6f\x6f\xe4\xac\x98\xb1\x73\xec\xc0\xbc\x60\xb4\x2a\x95\x34\x98\xda\ + \\xfb\xa1\xae\x12\x2d\x4b\xd7\x36\x0f\x25\xfa\xab\xa4\xf3\xfc\xeb\xe2\x96\x91\x23\x25\x7f\x0c\x3d\x93\x48\xaf\x49\x36\x14\x00\xbc\ + \\xe8\x81\x6f\x4a\x38\x14\xf2\x00\xa3\xf9\x40\x43\x9c\x7a\x54\xc2\xbc\x70\x4f\x57\xda\x41\xe7\xf9\xc2\x5a\xd3\x3a\x54\xf4\xa0\x84\ + \\xb1\x7f\x55\x05\x59\x35\x7c\xbe\xed\xbd\x15\xc8\x7f\x97\xc5\xab\xba\x5a\xc7\xb5\xb6\xf6\xde\xaf\x3a\x47\x9c\x3a\x53\x02\xda\x25\ + \\x65\x3d\x7e\x6a\x54\x26\x8d\x49\x51\xa4\x77\xea\x50\x17\xd5\x5b\xd7\xd2\x5d\x88\x44\x13\x6c\x76\x04\x04\xa8\xc8\xb8\xe5\xa1\x21\ + \\xb8\x1a\x92\x8a\x60\xed\x58\x69\x97\xc5\x5b\x96\xea\xec\x99\x1b\x29\x93\x59\x13\x01\xfd\xb7\xf1\x08\x8e\x8d\xfa\x9a\xb6\xf6\xf5\ + \\x3b\x4c\xbf\x9f\x4a\x5d\xe3\xab\xe6\x05\x1d\x35\xa0\xe1\xd8\x55\xd3\x6b\x4c\xf1\xf5\x44\xed\xeb\xb0\xe9\x35\x24\xbe\xbb\x8f\xbd\ + \\xa2\xd7\x62\xcf\x49\xc9\x2f\x54\x38\xb5\xf3\x31\x71\x28\xa4\x54\x48\x39\x29\x05\xa6\x5b\x1d\xb8\x85\x1c\x97\xbd\xd6\x75\xcf\x2f"# + +sbox_s7 :: Word8 -> Word32 +sbox_s7 i = arrayRead32 t (fromIntegral i) + where + t = array32FromAddrBE 256 + "\x85\xe0\x40\x19\x33\x2b\xf5\x67\x66\x2d\xbf\xff\xcf\xc6\x56\x93\x2a\x8d\x7f\x6f\xab\x9b\xc9\x12\xde\x60\x08\xa1\x20\x28\xda\x1f\ + \\x02\x27\xbc\xe7\x4d\x64\x29\x16\x18\xfa\xc3\x00\x50\xf1\x8b\x82\x2c\xb2\xcb\x11\xb2\x32\xe7\x5c\x4b\x36\x95\xf2\xb2\x87\x07\xde\ + \\xa0\x5f\xbc\xf6\xcd\x41\x81\xe9\xe1\x50\x21\x0c\xe2\x4e\xf1\xbd\xb1\x68\xc3\x81\xfd\xe4\xe7\x89\x5c\x79\xb0\xd8\x1e\x8b\xfd\x43\ + \\x4d\x49\x50\x01\x38\xbe\x43\x41\x91\x3c\xee\x1d\x92\xa7\x9c\x3f\x08\x97\x66\xbe\xba\xee\xad\xf4\x12\x86\xbe\xcf\xb6\xea\xcb\x19\ + \\x26\x60\xc2\x00\x75\x65\xbd\xe4\x64\x24\x1f\x7a\x82\x48\xdc\xa9\xc3\xb3\xad\x66\x28\x13\x60\x86\x0b\xd8\xdf\xa8\x35\x6d\x1c\xf2\ + \\x10\x77\x89\xbe\xb3\xb2\xe9\xce\x05\x02\xaa\x8f\x0b\xc0\x35\x1e\x16\x6b\xf5\x2a\xeb\x12\xff\x82\xe3\x48\x69\x11\xd3\x4d\x75\x16\ + \\x4e\x7b\x3a\xff\x5f\x43\x67\x1b\x9c\xf6\xe0\x37\x49\x81\xac\x83\x33\x42\x66\xce\x8c\x93\x41\xb7\xd0\xd8\x54\xc0\xcb\x3a\x6c\x88\ + \\x47\xbc\x28\x29\x47\x25\xba\x37\xa6\x6a\xd2\x2b\x7a\xd6\x1f\x1e\x0c\x5c\xba\xfa\x44\x37\xf1\x07\xb6\xe7\x99\x62\x42\xd2\xd8\x16\ + \\x0a\x96\x12\x88\xe1\xa5\xc0\x6e\x13\x74\x9e\x67\x72\xfc\x08\x1a\xb1\xd1\x39\xf7\xf9\x58\x37\x45\xcf\x19\xdf\x58\xbe\xc3\xf7\x56\ + \\xc0\x6e\xba\x30\x07\x21\x1b\x24\x45\xc2\x88\x29\xc9\x5e\x31\x7f\xbc\x8e\xc5\x11\x38\xbc\x46\xe9\xc6\xe6\xfa\x14\xba\xe8\x58\x4a\ + \\xad\x4e\xbc\x46\x46\x8f\x50\x8b\x78\x29\x43\x5f\xf1\x24\x18\x3b\x82\x1d\xba\x9f\xaf\xf6\x0f\xf4\xea\x2c\x4e\x6d\x16\xe3\x92\x64\ + \\x92\x54\x4a\x8b\x00\x9b\x4f\xc3\xab\xa6\x8c\xed\x9a\xc9\x6f\x78\x06\xa5\xb7\x9a\xb2\x85\x6e\x6e\x1a\xec\x3c\xa9\xbe\x83\x86\x88\ + \\x0e\x08\x04\xe9\x55\xf1\xbe\x56\xe7\xe5\x36\x3b\xb3\xa1\xf2\x5d\xf7\xde\xbb\x85\x61\xfe\x03\x3c\x16\x74\x62\x33\x3c\x03\x4c\x28\ + \\xda\x6d\x0c\x74\x79\xaa\xc5\x6c\x3c\xe4\xe1\xad\x51\xf0\xc8\x02\x98\xf8\xf3\x5a\x16\x26\xa4\x9f\xee\xd8\x2b\x29\x1d\x38\x2f\xe3\ + \\x0c\x4f\xb9\x9a\xbb\x32\x57\x78\x3e\xc6\xd9\x7b\x6e\x77\xa6\xa9\xcb\x65\x8b\x5c\xd4\x52\x30\xc7\x2b\xd1\x40\x8b\x60\xc0\x3e\xb7\ + \\xb9\x06\x8d\x78\xa3\x37\x54\xf4\xf4\x30\xc8\x7d\xc8\xa7\x13\x02\xb9\x6d\x8c\x32\xeb\xd4\xe7\xbe\xbe\x8b\x9d\x2d\x79\x79\xfb\x06\ + \\xe7\x22\x53\x08\x8b\x75\xcf\x77\x11\xef\x8d\xa4\xe0\x83\xc8\x58\x8d\x6b\x78\x6f\x5a\x63\x17\xa6\xfa\x5c\xf7\xa0\x5d\xda\x00\x33\ + \\xf2\x8e\xbf\xb0\xf5\xb9\xc3\x10\xa0\xea\xc2\x80\x08\xb9\x76\x7a\xa3\xd9\xd2\xb0\x79\xd3\x42\x17\x02\x1a\x71\x8d\x9a\xc6\x33\x6a\ + \\x27\x11\xfd\x60\x43\x80\x50\xe3\x06\x99\x08\xa8\x3d\x7f\xed\xc4\x82\x6d\x2b\xef\x4e\xeb\x84\x76\x48\x8d\xcf\x25\x36\xc9\xd5\x66\ + \\x28\xe7\x4e\x41\xc2\x61\x0a\xca\x3d\x49\xa9\xcf\xba\xe3\xb9\xdf\xb6\x5f\x8d\xe6\x92\xae\xaf\x64\x3a\xc7\xd5\xe6\x9e\xa8\x05\x09\ + \\xf2\x2b\x01\x7d\xa4\x17\x3f\x70\xdd\x1e\x16\xc3\x15\xe0\xd7\xf9\x50\xb1\xb8\x87\x2b\x9f\x4f\xd5\x62\x5a\xba\x82\x6a\x01\x79\x62\ + \\x2e\xc0\x1b\x9c\x15\x48\x8a\xa9\xd7\x16\xe7\x40\x40\x05\x5a\x2c\x93\xd2\x9a\x22\xe3\x2d\xbf\x9a\x05\x87\x45\xb9\x34\x53\xdc\x1e\ + \\xd6\x99\x29\x6e\x49\x6c\xff\x6f\x1c\x9f\x49\x86\xdf\xe2\xed\x07\xb8\x72\x42\xd1\x19\xde\x7e\xae\x05\x3e\x56\x1a\x15\xad\x6f\x8c\ + \\x66\x62\x6c\x1c\x71\x54\xc2\x4c\xea\x08\x2b\x2a\x93\xeb\x29\x39\x17\xdc\xb0\xf0\x58\xd4\xf2\xae\x9e\xa2\x94\xfb\x52\xcf\x56\x4c\ + \\x98\x83\xfe\x66\x2e\xc4\x05\x81\x76\x39\x53\xc3\x01\xd6\x69\x2e\xd3\xa0\xc1\x08\xa1\xe7\x16\x0e\xe4\xf2\xdf\xa6\x69\x3e\xd2\x85\ + \\x74\x90\x46\x98\x4c\x2b\x0e\xdd\x4f\x75\x76\x56\x5d\x39\x33\x78\xa1\x32\x23\x4f\x3d\x32\x1c\x5d\xc3\xf5\xe1\x94\x4b\x26\x93\x01\ + \\xc7\x9f\x02\x2f\x3c\x99\x7e\x7e\x5e\x4f\x95\x04\x3f\xfa\xfb\xbd\x76\xf7\xad\x0e\x29\x66\x93\xf4\x3d\x1f\xce\x6f\xc6\x1e\x45\xbe\ + \\xd3\xb5\xab\x34\xf7\x2b\xf9\xb7\x1b\x04\x34\xc0\x4e\x72\xb5\x67\x55\x92\xa3\x3d\xb5\x22\x93\x01\xcf\xd2\xa8\x7f\x60\xae\xb7\x67\ + \\x18\x14\x38\x6b\x30\xbc\xc3\x3d\x38\xa0\xc0\x7d\xfd\x16\x06\xf2\xc3\x63\x51\x9b\x58\x9d\xd3\x90\x54\x79\xf8\xe6\x1c\xb8\xd6\x47\ + \\x97\xfd\x61\xa9\xea\x77\x59\xf4\x2d\x57\x53\x9d\x56\x9a\x58\xcf\xe8\x4e\x63\xad\x46\x2e\x1b\x78\x65\x80\xf8\x7e\xf3\x81\x79\x14\ + \\x91\xda\x55\xf4\x40\xa2\x30\xf3\xd1\x98\x8f\x35\xb6\xe3\x18\xd2\x3f\xfa\x50\xbc\x3d\x40\xf0\x21\xc3\xc0\xbd\xae\x49\x58\xc2\x4c\ + \\x51\x8f\x36\xb2\x84\xb1\xd3\x70\x0f\xed\xce\x83\x87\x8d\xda\xda\xf2\xa2\x79\xc7\x94\xe0\x1b\xe8\x90\x71\x6f\x4b\x95\x4b\x8a\xa3"# + +sbox_s8 :: Word8 -> Word32 +sbox_s8 i = arrayRead32 t (fromIntegral i) + where + t = array32FromAddrBE 256 + "\xe2\x16\x30\x0d\xbb\xdd\xff\xfc\xa7\xeb\xda\xbd\x35\x64\x80\x95\x77\x89\xf8\xb7\xe6\xc1\x12\x1b\x0e\x24\x16\x00\x05\x2c\xe8\xb5\ + \\x11\xa9\xcf\xb0\xe5\x95\x2f\x11\xec\xe7\x99\x0a\x93\x86\xd1\x74\x2a\x42\x93\x1c\x76\xe3\x81\x11\xb1\x2d\xef\x3a\x37\xdd\xdd\xfc\ + \\xde\x9a\xde\xb1\x0a\x0c\xc3\x2c\xbe\x19\x70\x29\x84\xa0\x09\x40\xbb\x24\x3a\x0f\xb4\xd1\x37\xcf\xb4\x4e\x79\xf0\x04\x9e\xed\xfd\ + \\x0b\x15\xa1\x5d\x48\x0d\x31\x68\x8b\xbb\xde\x5a\x66\x9d\xed\x42\xc7\xec\xe8\x31\x3f\x8f\x95\xe7\x72\xdf\x19\x1b\x75\x80\x33\x0d\ + \\x94\x07\x42\x51\x5c\x7d\xcd\xfa\xab\xbe\x6d\x63\xaa\x40\x21\x64\xb3\x01\xd4\x0a\x02\xe7\xd1\xca\x53\x57\x1d\xae\x7a\x31\x82\xa2\ + \\x12\xa8\xdd\xec\xfd\xaa\x33\x5d\x17\x6f\x43\xe8\x71\xfb\x46\xd4\x38\x12\x90\x22\xce\x94\x9a\xd4\xb8\x47\x69\xad\x96\x5b\xd8\x62\ + \\x82\xf3\xd0\x55\x66\xfb\x97\x67\x15\xb8\x0b\x4e\x1d\x5b\x47\xa0\x4c\xfd\xe0\x6f\xc2\x8e\xc4\xb8\x57\xe8\x72\x6e\x64\x7a\x78\xfc\ + \\x99\x86\x5d\x44\x60\x8b\xd5\x93\x6c\x20\x0e\x03\x39\xdc\x5f\xf6\x5d\x0b\x00\xa3\xae\x63\xaf\xf2\x7e\x8b\xd6\x32\x70\x10\x8c\x0c\ + \\xbb\xd3\x50\x49\x29\x98\xdf\x04\x98\x0c\xf4\x2a\x9b\x6d\xf4\x91\x9e\x7e\xdd\x53\x06\x91\x85\x48\x58\xcb\x7e\x07\x3b\x74\xef\x2e\ + \\x52\x2f\xff\xb1\xd2\x47\x08\xcc\x1c\x7e\x27\xcd\xa4\xeb\x21\x5b\x3c\xf1\xd2\xe2\x19\xb4\x7a\x38\x42\x4f\x76\x18\x35\x85\x60\x39\ + \\x9d\x17\xde\xe7\x27\xeb\x35\xe6\xc9\xaf\xf6\x7b\x36\xba\xf5\xb8\x09\xc4\x67\xcd\xc1\x89\x10\xb1\xe1\x1d\xbf\x7b\x06\xcd\x1a\xf8\ + \\x71\x70\xc6\x08\x2d\x5e\x33\x54\xd4\xde\x49\x5a\x64\xc6\xd0\x06\xbc\xc0\xc6\x2c\x3d\xd0\x0d\xb3\x70\x8f\x8f\x34\x77\xd5\x1b\x42\ + \\x26\x4f\x62\x0f\x24\xb8\xd2\xbf\x15\xc1\xb7\x9e\x46\xa5\x25\x64\xf8\xd7\xe5\x4e\x3e\x37\x81\x60\x78\x95\xcd\xa5\x85\x9c\x15\xa5\ + \\xe6\x45\x97\x88\xc3\x7b\xc7\x5f\xdb\x07\xba\x0c\x06\x76\xa3\xab\x7f\x22\x9b\x1e\x31\x84\x2e\x7b\x24\x25\x9f\xd7\xf8\xbe\xf4\x72\ + \\x83\x5f\xfc\xb8\x6d\xf4\xc1\xf2\x96\xf5\xb1\x95\xfd\x0a\xf0\xfc\xb0\xfe\x13\x4c\xe2\x50\x6d\x3d\x4f\x9b\x12\xea\xf2\x15\xf2\x25\ + \\xa2\x23\x73\x6f\x9f\xb4\xc4\x28\x25\xd0\x49\x79\x34\xc7\x13\xf8\xc4\x61\x81\x87\xea\x7a\x6e\x98\x7c\xd1\x6e\xfc\x14\x36\x87\x6c\ + \\xf1\x54\x41\x07\xbe\xde\xee\x14\x56\xe9\xaf\x27\xa0\x4a\xa4\x41\x3c\xf7\xc8\x99\x92\xec\xba\xe6\xdd\x67\x01\x6d\x15\x16\x82\xeb\ + \\xa8\x42\xee\xdf\xfd\xba\x60\xb4\xf1\x90\x7b\x75\x20\xe3\x03\x0f\x24\xd8\xc2\x9e\xe1\x39\x67\x3b\xef\xa6\x3f\xb8\x71\x87\x30\x54\ + \\xb6\xf2\xcf\x3b\x9f\x32\x64\x42\xcb\x15\xa4\xcc\xb0\x1a\x45\x04\xf1\xe4\x7d\x8d\x84\x4a\x1b\xe5\xba\xe7\xdf\xdc\x42\xcb\xda\x70\ + \\xcd\x7d\xae\x0a\x57\xe8\x5b\x7a\xd5\x3f\x5a\xf6\x20\xcf\x4d\x8c\xce\xa4\xd4\x28\x79\xd1\x30\xa4\x34\x86\xeb\xfb\x33\xd3\xcd\xdc\ + \\x77\x85\x3b\x53\x37\xef\xfc\xb5\xc5\x06\x87\x78\xe5\x80\xb3\xe6\x4e\x68\xb8\xf4\xc5\xc8\xb3\x7e\x0d\x80\x9e\xa2\x39\x8f\xeb\x7c\ + \\x13\x2a\x4f\x94\x43\xb7\x95\x0e\x2f\xee\x7d\x1c\x22\x36\x13\xbd\xdd\x06\xca\xa2\x37\xdf\x93\x2b\xc4\x24\x82\x89\xac\xf3\xeb\xc3\ + \\x57\x15\xf6\xb7\xef\x34\x78\xdd\xf2\x67\x61\x6f\xc1\x48\xcb\xe4\x90\x52\x81\x5e\x5e\x41\x0f\xab\xb4\x8a\x24\x65\x2e\xda\x7f\xa4\ + \\xe8\x7b\x40\xe4\xe9\x8e\xa0\x84\x58\x89\xe9\xe1\xef\xd3\x90\xfc\xdd\x07\xd3\x5b\xdb\x48\x56\x94\x38\xd7\xe5\xb2\x57\x72\x01\x01\ + \\x73\x0e\xde\xbc\x5b\x64\x31\x13\x94\x91\x7e\x4f\x50\x3c\x2f\xba\x64\x6f\x12\x82\x75\x23\xd2\x4a\xe0\x77\x96\x95\xf9\xc1\x7a\x8f\ + \\x7a\x5b\x21\x21\xd1\x87\xb8\x96\x29\x26\x3a\x4d\xba\x51\x0c\xdf\x81\xf4\x7c\x9f\xad\x11\x63\xed\xea\x7b\x59\x65\x1a\x00\x72\x6e\ + \\x11\x40\x30\x92\x00\xda\x6d\x77\x4a\x0c\xdd\x61\xad\x1f\x46\x03\x60\x5b\xdf\xb0\x9e\xed\xc3\x64\x22\xeb\xe6\xa8\xce\xe7\xd2\x8a\ + \\xa0\xe7\x36\xa0\x55\x64\xa6\xb9\x10\x85\x32\x09\xc7\xeb\x8f\x37\x2d\xe7\x05\xca\x89\x51\x57\x0f\xdf\x09\x82\x2b\xbd\x69\x1a\x6c\ + \\xaa\x12\xe4\xf2\x87\x45\x1c\x0f\xe0\xf6\xa2\x7a\x3a\xda\x48\x19\x4c\xf1\x76\x4f\x0d\x77\x1c\x2b\x67\xcd\xb1\x56\x35\x0d\x83\x84\ + \\x59\x38\xfa\x0f\x42\x39\x9e\xf3\x36\x99\x7b\x07\x0e\x84\x09\x3d\x4a\xa9\x3e\x61\x83\x60\xd8\x7b\x1f\xa9\x8b\x0c\x11\x49\x38\x2c\ + \\xe9\x76\x25\xa5\x06\x14\xd1\xb7\x0e\x25\x24\x4b\x0c\x76\x83\x47\x58\x9e\x8d\x82\x0d\x20\x59\xd1\xa4\x66\xbb\x1e\xf8\xda\x0a\x82\ + \\x04\xf1\x91\x30\xba\x6e\x4e\xc0\x99\x26\x51\x64\x1e\xe7\x23\x0d\x50\xb2\xad\x80\xea\xee\x68\x01\x8d\xb2\xa2\x83\xea\x8b\xf5\x9e"# diff --git a/bundled/Crypto/Cipher/Camellia.hs b/bundled/Crypto/Cipher/Camellia.hs new file mode 100644 index 0000000..985a43d --- /dev/null +++ b/bundled/Crypto/Cipher/Camellia.hs @@ -0,0 +1,28 @@ +-- | +-- Module : Crypto.Cipher.Camellia +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +-- Camellia support. only 128 bit variant available for now. + +module Crypto.Cipher.Camellia + ( Camellia128 + ) where + +import Crypto.Cipher.Camellia.Primitive +import Crypto.Cipher.Types + +-- | Camellia block cipher with 128 bit key +newtype Camellia128 = Camellia128 Camellia + +instance Cipher Camellia128 where + cipherName _ = "Camellia128" + cipherKeySize _ = KeySizeFixed 16 + cipherInit k = Camellia128 `fmap` initCamellia k + +instance BlockCipher Camellia128 where + blockSize _ = 16 + ecbEncrypt (Camellia128 key) = encrypt key + ecbDecrypt (Camellia128 key) = decrypt key diff --git a/bundled/Crypto/Cipher/Camellia/Primitive.hs b/bundled/Crypto/Cipher/Camellia/Primitive.hs new file mode 100644 index 0000000..8d683d0 --- /dev/null +++ b/bundled/Crypto/Cipher/Camellia/Primitive.hs @@ -0,0 +1,283 @@ + +-- | +-- Module : Crypto.Cipher.Camellia.Primitive +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +-- This only cover Camellia 128 bits for now. The API will change once +-- 192 and 256 mode are implemented too. +{-# LANGUAGE MagicHash #-} +module Crypto.Cipher.Camellia.Primitive + ( Camellia + , initCamellia + , encrypt + , decrypt + ) where + +import Data.Word +import Data.Bits + +import Crypto.Error +import Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray) +import qualified Crypto.Internal.ByteArray as B +import Crypto.Internal.Words +import Crypto.Internal.WordArray +import Data.Memory.Endian + +data Mode = Decrypt | Encrypt + +w64tow128 :: (Word64, Word64) -> Word128 +w64tow128 (x1, x2) = Word128 x1 x2 + +w64tow8 :: Word64 -> (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8) +w64tow8 x = (t1, t2, t3, t4, t5, t6, t7, t8) + where + t1 = fromIntegral (x `shiftR` 56) + t2 = fromIntegral (x `shiftR` 48) + t3 = fromIntegral (x `shiftR` 40) + t4 = fromIntegral (x `shiftR` 32) + t5 = fromIntegral (x `shiftR` 24) + t6 = fromIntegral (x `shiftR` 16) + t7 = fromIntegral (x `shiftR` 8) + t8 = fromIntegral (x) + +w8tow64 :: (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8) -> Word64 +w8tow64 (t1,t2,t3,t4,t5,t6,t7,t8) = + (fromIntegral t1 `shiftL` 56) .|. + (fromIntegral t2 `shiftL` 48) .|. + (fromIntegral t3 `shiftL` 40) .|. + (fromIntegral t4 `shiftL` 32) .|. + (fromIntegral t5 `shiftL` 24) .|. + (fromIntegral t6 `shiftL` 16) .|. + (fromIntegral t7 `shiftL` 8) .|. + (fromIntegral t8) + +sbox :: Int -> Word8 +sbox = arrayRead8 t + where t = array8 + "\x70\x82\x2c\xec\xb3\x27\xc0\xe5\xe4\x85\x57\x35\xea\x0c\xae\x41\ + \\x23\xef\x6b\x93\x45\x19\xa5\x21\xed\x0e\x4f\x4e\x1d\x65\x92\xbd\ + \\x86\xb8\xaf\x8f\x7c\xeb\x1f\xce\x3e\x30\xdc\x5f\x5e\xc5\x0b\x1a\ + \\xa6\xe1\x39\xca\xd5\x47\x5d\x3d\xd9\x01\x5a\xd6\x51\x56\x6c\x4d\ + \\x8b\x0d\x9a\x66\xfb\xcc\xb0\x2d\x74\x12\x2b\x20\xf0\xb1\x84\x99\ + \\xdf\x4c\xcb\xc2\x34\x7e\x76\x05\x6d\xb7\xa9\x31\xd1\x17\x04\xd7\ + \\x14\x58\x3a\x61\xde\x1b\x11\x1c\x32\x0f\x9c\x16\x53\x18\xf2\x22\ + \\xfe\x44\xcf\xb2\xc3\xb5\x7a\x91\x24\x08\xe8\xa8\x60\xfc\x69\x50\ + \\xaa\xd0\xa0\x7d\xa1\x89\x62\x97\x54\x5b\x1e\x95\xe0\xff\x64\xd2\ + \\x10\xc4\x00\x48\xa3\xf7\x75\xdb\x8a\x03\xe6\xda\x09\x3f\xdd\x94\ + \\x87\x5c\x83\x02\xcd\x4a\x90\x33\x73\x67\xf6\xf3\x9d\x7f\xbf\xe2\ + \\x52\x9b\xd8\x26\xc8\x37\xc6\x3b\x81\x96\x6f\x4b\x13\xbe\x63\x2e\ + \\xe9\x79\xa7\x8c\x9f\x6e\xbc\x8e\x29\xf5\xf9\xb6\x2f\xfd\xb4\x59\ + \\x78\x98\x06\x6a\xe7\x46\x71\xba\xd4\x25\xab\x42\x88\xa2\x8d\xfa\ + \\x72\x07\xb9\x55\xf8\xee\xac\x0a\x36\x49\x2a\x68\x3c\x38\xf1\xa4\ + \\x40\x28\xd3\x7b\xbb\xc9\x43\xc1\x15\xe3\xad\xf4\x77\xc7\x80\x9e"# + +sbox1 :: Word8 -> Word8 +sbox1 x = sbox (fromIntegral x) + +sbox2 :: Word8 -> Word8 +sbox2 x = sbox1 x `rotateL` 1 + +sbox3 :: Word8 -> Word8 +sbox3 x = sbox1 x `rotateL` 7 + +sbox4 :: Word8 -> Word8 +sbox4 x = sbox1 (x `rotateL` 1) + +sigma1, sigma2, sigma3, sigma4, sigma5, sigma6 :: Word64 +sigma1 = 0xA09E667F3BCC908B +sigma2 = 0xB67AE8584CAA73B2 +sigma3 = 0xC6EF372FE94F82BE +sigma4 = 0x54FF53A5F1D36F1C +sigma5 = 0x10E527FADE682D1D +sigma6 = 0xB05688C2B3E6C1FD + +rotl128 :: Word128 -> Int -> Word128 +rotl128 v 0 = v +rotl128 (Word128 x1 x2) 64 = Word128 x2 x1 + +rotl128 v@(Word128 x1 x2) w + | w > 64 = (v `rotl128` 64) `rotl128` (w - 64) + | otherwise = Word128 (x1high .|. x2low) (x2high .|. x1low) + where + splitBits i = (i .&. complement x, i .&. x) + where x = 2 ^ w - 1 + (x1high, x1low) = splitBits (x1 `rotateL` w) + (x2high, x2low) = splitBits (x2 `rotateL` w) + +-- | Camellia context +data Camellia = Camellia + { k :: Array64 + , kw :: Array64 + , ke :: Array64 + } + +setKeyInterim :: ByteArrayAccess key => key -> (Word128, Word128, Word128, Word128) +setKeyInterim keyseed = (w64tow128 kL, w64tow128 kR, w64tow128 kA, w64tow128 kB) + where kL = (fromBE $ B.toW64BE keyseed 0, fromBE $ B.toW64BE keyseed 8) + kR = (0, 0) + + kA = let d1 = (fst kL `xor` fst kR) + d2 = (snd kL `xor` snd kR) + d3 = d2 `xor` feistel d1 sigma1 + d4 = d1 `xor` feistel d3 sigma2 + d5 = d4 `xor` (fst kL) + d6 = d3 `xor` (snd kL) + d7 = d6 `xor` feistel d5 sigma3 + d8 = d5 `xor` feistel d7 sigma4 + in (d8, d7) + + kB = let d1 = (fst kA `xor` fst kR) + d2 = (snd kA `xor` snd kR) + d3 = d2 `xor` feistel d1 sigma5 + d4 = d1 `xor` feistel d3 sigma6 + in (d4, d3) + +-- | Initialize a 128-bit key +-- +-- Return the initialized key or a error message if the given +-- keyseed was not 16-bytes in length. +initCamellia :: ByteArray key + => key -- ^ The key to create the camellia context + -> CryptoFailable Camellia +initCamellia key + | B.length key /= 16 = CryptoFailed $ CryptoError_KeySizeInvalid + | otherwise = + let (kL, _, kA, _) = setKeyInterim key in + + let (Word128 kw1 kw2) = (kL `rotl128` 0) in + let (Word128 k1 k2) = (kA `rotl128` 0) in + let (Word128 k3 k4) = (kL `rotl128` 15) in + let (Word128 k5 k6) = (kA `rotl128` 15) in + let (Word128 ke1 ke2) = (kA `rotl128` 30) in --ke1 = (KA <<< 30) >> 64; ke2 = (KA <<< 30) & MASK64; + let (Word128 k7 k8) = (kL `rotl128` 45) in --k7 = (KL <<< 45) >> 64; k8 = (KL <<< 45) & MASK64; + let (Word128 k9 _) = (kA `rotl128` 45) in --k9 = (KA <<< 45) >> 64; + let (Word128 _ k10) = (kL `rotl128` 60) in + let (Word128 k11 k12) = (kA `rotl128` 60) in + let (Word128 ke3 ke4) = (kL `rotl128` 77) in + let (Word128 k13 k14) = (kL `rotl128` 94) in + let (Word128 k15 k16) = (kA `rotl128` 94) in + let (Word128 k17 k18) = (kL `rotl128` 111) in + let (Word128 kw3 kw4) = (kA `rotl128` 111) in + + CryptoPassed $ Camellia + { kw = array64 4 [ kw1, kw2, kw3, kw4 ] + , ke = array64 4 [ ke1, ke2, ke3, ke4 ] + , k = array64 18 [ k1, k2, k3, k4, k5, k6, k7, k8, k9, k10, k11, k12, k13, k14, k15, k16, k17, k18 ] + } + +feistel :: Word64 -> Word64 -> Word64 +feistel fin sk = + let x = fin `xor` sk in + let (t1, t2, t3, t4, t5, t6, t7, t8) = w64tow8 x in + let t1' = sbox1 t1 in + let t2' = sbox2 t2 in + let t3' = sbox3 t3 in + let t4' = sbox4 t4 in + let t5' = sbox2 t5 in + let t6' = sbox3 t6 in + let t7' = sbox4 t7 in + let t8' = sbox1 t8 in + let y1 = t1' `xor` t3' `xor` t4' `xor` t6' `xor` t7' `xor` t8' in + let y2 = t1' `xor` t2' `xor` t4' `xor` t5' `xor` t7' `xor` t8' in + let y3 = t1' `xor` t2' `xor` t3' `xor` t5' `xor` t6' `xor` t8' in + let y4 = t2' `xor` t3' `xor` t4' `xor` t5' `xor` t6' `xor` t7' in + let y5 = t1' `xor` t2' `xor` t6' `xor` t7' `xor` t8' in + let y6 = t2' `xor` t3' `xor` t5' `xor` t7' `xor` t8' in + let y7 = t3' `xor` t4' `xor` t5' `xor` t6' `xor` t8' in + let y8 = t1' `xor` t4' `xor` t5' `xor` t6' `xor` t7' in + w8tow64 (y1, y2, y3, y4, y5, y6, y7, y8) + +fl :: Word64 -> Word64 -> Word64 +fl fin sk = + let (x1, x2) = w64to32 fin in + let (k1, k2) = w64to32 sk in + let y2 = x2 `xor` ((x1 .&. k1) `rotateL` 1) in + let y1 = x1 `xor` (y2 .|. k2) in + w32to64 (y1, y2) + +flinv :: Word64 -> Word64 -> Word64 +flinv fin sk = + let (y1, y2) = w64to32 fin in + let (k1, k2) = w64to32 sk in + let x1 = y1 `xor` (y2 .|. k2) in + let x2 = y2 `xor` ((x1 .&. k1) `rotateL` 1) in + w32to64 (x1, x2) + +{- in decrypt mode 0->17 1->16 ... -} +getKeyK :: Mode -> Camellia -> Int -> Word64 +getKeyK Encrypt key i = k key `arrayRead64` i +getKeyK Decrypt key i = k key `arrayRead64` (17 - i) + +{- in decrypt mode 0->3 1->2 2->1 3->0 -} +getKeyKe :: Mode -> Camellia -> Int -> Word64 +getKeyKe Encrypt key i = ke key `arrayRead64` i +getKeyKe Decrypt key i = ke key `arrayRead64` (3 - i) + +{- in decrypt mode 0->2 1->3 2->0 3->1 -} +getKeyKw :: Mode -> Camellia -> Int -> Word64 +getKeyKw Encrypt key i = (kw key) `arrayRead64` i +getKeyKw Decrypt key i = (kw key) `arrayRead64` ((i + 2) `mod` 4) + +{- perform the following + D2 = D2 ^ F(D1, k1); // Round 1 + D1 = D1 ^ F(D2, k2); // Round 2 + D2 = D2 ^ F(D1, k3); // Round 3 + D1 = D1 ^ F(D2, k4); // Round 4 + D2 = D2 ^ F(D1, k5); // Round 5 + D1 = D1 ^ F(D2, k6); // Round 6 + -} +doBlockRound :: Mode -> Camellia -> Word64 -> Word64 -> Int -> (Word64, Word64) +doBlockRound mode key d1 d2 i = + let r1 = d2 `xor` feistel d1 (getKeyK mode key (0+i)) in {- Round 1+i -} + let r2 = d1 `xor` feistel r1 (getKeyK mode key (1+i)) in {- Round 2+i -} + let r3 = r1 `xor` feistel r2 (getKeyK mode key (2+i)) in {- Round 3+i -} + let r4 = r2 `xor` feistel r3 (getKeyK mode key (3+i)) in {- Round 4+i -} + let r5 = r3 `xor` feistel r4 (getKeyK mode key (4+i)) in {- Round 5+i -} + let r6 = r4 `xor` feistel r5 (getKeyK mode key (5+i)) in {- Round 6+i -} + (r6, r5) + +doBlock :: Mode -> Camellia -> Word128 -> Word128 +doBlock mode key (Word128 d1 d2) = + let d1a = d1 `xor` (getKeyKw mode key 0) in {- Prewhitening -} + let d2a = d2 `xor` (getKeyKw mode key 1) in + + let (d1b, d2b) = doBlockRound mode key d1a d2a 0 in + + let d1c = fl d1b (getKeyKe mode key 0) in {- FL -} + let d2c = flinv d2b (getKeyKe mode key 1) in {- FLINV -} + + let (d1d, d2d) = doBlockRound mode key d1c d2c 6 in + + let d1e = fl d1d (getKeyKe mode key 2) in {- FL -} + let d2e = flinv d2d (getKeyKe mode key 3) in {- FLINV -} + + let (d1f, d2f) = doBlockRound mode key d1e d2e 12 in + + let d2g = d2f `xor` (getKeyKw mode key 2) in {- Postwhitening -} + let d1g = d1f `xor` (getKeyKw mode key 3) in + w64tow128 (d2g, d1g) + +{- encryption for 128 bits blocks -} +encryptBlock :: Camellia -> Word128 -> Word128 +encryptBlock = doBlock Encrypt + +{- decryption for 128 bits blocks -} +decryptBlock :: Camellia -> Word128 -> Word128 +decryptBlock = doBlock Decrypt + +-- | Encrypts the given ByteString using the given Key +encrypt :: ByteArray ba + => Camellia -- ^ The key to use + -> ba -- ^ The data to encrypt + -> ba +encrypt key = B.mapAsWord128 (encryptBlock key) + +-- | Decrypts the given ByteString using the given Key +decrypt :: ByteArray ba + => Camellia -- ^ The key to use + -> ba -- ^ The data to decrypt + -> ba +decrypt key = B.mapAsWord128 (decryptBlock key) diff --git a/bundled/Crypto/Cipher/ChaCha.hs b/bundled/Crypto/Cipher/ChaCha.hs new file mode 100644 index 0000000..8d9c638 --- /dev/null +++ b/bundled/Crypto/Cipher/ChaCha.hs @@ -0,0 +1,126 @@ +-- | +-- Module : Crypto.Cipher.ChaCha +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : good +-- +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Crypto.Cipher.ChaCha + ( initialize + , combine + , generate + , State + -- * Simple interface for DRG purpose + , initializeSimple + , generateSimple + , StateSimple + ) where + +import Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, ScrubbedBytes) +import qualified Crypto.Internal.ByteArray as B +import Crypto.Internal.Compat +import Crypto.Internal.Imports +import Foreign.Ptr +import Foreign.C.Types + +-- | ChaCha context +newtype State = State ScrubbedBytes + deriving (NFData) + +-- | ChaCha context for DRG purpose (see Crypto.Random.ChaChaDRG) +newtype StateSimple = StateSimple ScrubbedBytes -- just ChaCha's state + deriving (NFData) + +-- | Initialize a new ChaCha context with the number of rounds, +-- the key and the nonce associated. +initialize :: (ByteArrayAccess key, ByteArrayAccess nonce) + => Int -- ^ number of rounds (8,12,20) + -> key -- ^ the key (128 or 256 bits) + -> nonce -- ^ the nonce (64 or 96 bits) + -> State -- ^ the initial ChaCha state +initialize nbRounds key nonce + | kLen `notElem` [16,32] = error "ChaCha: key length should be 128 or 256 bits" + | nonceLen `notElem` [8,12] = error "ChaCha: nonce length should be 64 or 96 bits" + | nbRounds `notElem` [8,12,20] = error "ChaCha: rounds should be 8, 12 or 20" + | otherwise = unsafeDoIO $ do + stPtr <- B.alloc 132 $ \stPtr -> + B.withByteArray nonce $ \noncePtr -> + B.withByteArray key $ \keyPtr -> + ccryptonite_chacha_init stPtr nbRounds kLen keyPtr nonceLen noncePtr + return $ State stPtr + where kLen = B.length key + nonceLen = B.length nonce + +-- | Initialize simple ChaCha State +-- +-- The seed need to be at least 40 bytes long +initializeSimple :: ByteArrayAccess seed + => seed -- ^ a 40 bytes long seed + -> StateSimple +initializeSimple seed + | sLen < 40 = error "ChaCha Random: seed length should be 40 bytes" + | otherwise = unsafeDoIO $ do + stPtr <- B.alloc 64 $ \stPtr -> + B.withByteArray seed $ \seedPtr -> + ccryptonite_chacha_init_core stPtr 32 seedPtr 8 (seedPtr `plusPtr` 32) + return $ StateSimple stPtr + where + sLen = B.length seed + +-- | Combine the chacha output and an arbitrary message with a xor, +-- and return the combined output and the new state. +combine :: ByteArray ba + => State -- ^ the current ChaCha state + -> ba -- ^ the source to xor with the generator + -> (ba, State) +combine prevSt@(State prevStMem) src + | B.null src = (B.empty, prevSt) + | otherwise = unsafeDoIO $ do + (out, st) <- B.copyRet prevStMem $ \ctx -> + B.alloc (B.length src) $ \dstPtr -> + B.withByteArray src $ \srcPtr -> + ccryptonite_chacha_combine dstPtr ctx srcPtr (fromIntegral $ B.length src) + return (out, State st) + +-- | Generate a number of bytes from the ChaCha output directly +generate :: ByteArray ba + => State -- ^ the current ChaCha state + -> Int -- ^ the length of data to generate + -> (ba, State) +generate prevSt@(State prevStMem) len + | len <= 0 = (B.empty, prevSt) + | otherwise = unsafeDoIO $ do + (out, st) <- B.copyRet prevStMem $ \ctx -> + B.alloc len $ \dstPtr -> + ccryptonite_chacha_generate dstPtr ctx (fromIntegral len) + return (out, State st) + +-- | similar to 'generate' but assume certains values +generateSimple :: ByteArray ba + => StateSimple + -> Int + -> (ba, StateSimple) +generateSimple (StateSimple prevSt) nbBytes = unsafeDoIO $ do + newSt <- B.copy prevSt (\_ -> return ()) + output <- B.alloc nbBytes $ \dstPtr -> + B.withByteArray newSt $ \stPtr -> + ccryptonite_chacha_random 8 dstPtr stPtr (fromIntegral nbBytes) + return (output, StateSimple newSt) + +foreign import ccall "cryptonite_chacha_init_core" + ccryptonite_chacha_init_core :: Ptr StateSimple -> Int -> Ptr Word8 -> Int -> Ptr Word8 -> IO () + +foreign import ccall "cryptonite_chacha_init" + ccryptonite_chacha_init :: Ptr State -> Int -> Int -> Ptr Word8 -> Int -> Ptr Word8 -> IO () + +foreign import ccall "cryptonite_chacha_combine" + ccryptonite_chacha_combine :: Ptr Word8 -> Ptr State -> Ptr Word8 -> CUInt -> IO () + +foreign import ccall "cryptonite_chacha_generate" + ccryptonite_chacha_generate :: Ptr Word8 -> Ptr State -> CUInt -> IO () + +foreign import ccall "cryptonite_chacha_random" + ccryptonite_chacha_random :: Int -> Ptr Word8 -> Ptr StateSimple -> CUInt -> IO () + diff --git a/bundled/Crypto/Cipher/ChaChaPoly1305.hs b/bundled/Crypto/Cipher/ChaChaPoly1305.hs new file mode 100644 index 0000000..ae0121f --- /dev/null +++ b/bundled/Crypto/Cipher/ChaChaPoly1305.hs @@ -0,0 +1,201 @@ +-- | +-- Module : Crypto.Cipher.ChaChaPoly1305 +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : good +-- +-- A simple AEAD scheme using ChaCha20 and Poly1305. See +-- . +-- +-- The State is not modified in place, so each function changing the State, +-- returns a new State. +-- +-- Authenticated Data need to be added before any call to 'encrypt' or 'decrypt', +-- and once all the data has been added, then 'finalizeAAD' need to be called. +-- +-- Once 'finalizeAAD' has been called, no further 'appendAAD' call should be make. +-- +-- >import Data.ByteString.Char8 as B +-- >import Data.ByteArray +-- >import Crypto.Error +-- >import Crypto.Cipher.ChaChaPoly1305 as C +-- > +-- >encrypt +-- > :: ByteString -- nonce (12 random bytes) +-- > -> ByteString -- symmetric key +-- > -> ByteString -- optional associated data (won't be encrypted) +-- > -> ByteString -- input plaintext to be encrypted +-- > -> CryptoFailable ByteString -- ciphertext with a 128-bit tag attached +-- >encrypt nonce key header plaintext = do +-- > st1 <- C.nonce12 nonce >>= C.initialize key +-- > let +-- > st2 = C.finalizeAAD $ C.appendAAD header st1 +-- > (out, st3) = C.encrypt plaintext st2 +-- > auth = C.finalize st3 +-- > return $ out `B.append` Data.ByteArray.convert auth +-- +module Crypto.Cipher.ChaChaPoly1305 + ( State + , Nonce + , nonce12 + , nonce8 + , incrementNonce + , initialize + , appendAAD + , finalizeAAD + , encrypt + , decrypt + , finalize + ) where + +import Control.Monad (when) +import Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, Bytes, ScrubbedBytes) +import qualified Crypto.Internal.ByteArray as B +import Crypto.Internal.Imports +import Crypto.Error +import qualified Crypto.Cipher.ChaCha as ChaCha +import qualified Crypto.MAC.Poly1305 as Poly1305 +import Data.Memory.Endian +import qualified Data.ByteArray.Pack as P +import Foreign.Ptr +import Foreign.Storable + +-- | A ChaChaPoly1305 State. +-- +-- The state is immutable, and only new state can be created +data State = State !ChaCha.State + !Poly1305.State + !Word64 -- AAD length + !Word64 -- ciphertext length + +-- | Valid Nonce for ChaChaPoly1305. +-- +-- It can be created with 'nonce8' or 'nonce12' +data Nonce = Nonce8 Bytes | Nonce12 Bytes + +instance ByteArrayAccess Nonce where + length (Nonce8 n) = B.length n + length (Nonce12 n) = B.length n + + withByteArray (Nonce8 n) = B.withByteArray n + withByteArray (Nonce12 n) = B.withByteArray n + +-- Based on the following pseudo code: +-- +-- chacha20_aead_encrypt(aad, key, iv, constant, plaintext): +-- nonce = constant | iv +-- otk = poly1305_key_gen(key, nonce) +-- ciphertext = chacha20_encrypt(key, 1, nonce, plaintext) +-- mac_data = aad | pad16(aad) +-- mac_data |= ciphertext | pad16(ciphertext) +-- mac_data |= num_to_4_le_bytes(aad.length) +-- mac_data |= num_to_4_le_bytes(ciphertext.length) +-- tag = poly1305_mac(mac_data, otk) +-- return (ciphertext, tag) + +pad16 :: Word64 -> Bytes +pad16 n + | modLen == 0 = B.empty + | otherwise = B.replicate (16 - modLen) 0 + where + modLen = fromIntegral (n `mod` 16) + +-- | Nonce smart constructor 12 bytes IV, nonce constructor +nonce12 :: ByteArrayAccess iv => iv -> CryptoFailable Nonce +nonce12 iv + | B.length iv /= 12 = CryptoFailed CryptoError_IvSizeInvalid + | otherwise = CryptoPassed . Nonce12 . B.convert $ iv + +-- | 8 bytes IV, nonce constructor +nonce8 :: ByteArrayAccess ba + => ba -- ^ 4 bytes constant + -> ba -- ^ 8 bytes IV + -> CryptoFailable Nonce +nonce8 constant iv + | B.length constant /= 4 = CryptoFailed CryptoError_IvSizeInvalid + | B.length iv /= 8 = CryptoFailed CryptoError_IvSizeInvalid + | otherwise = CryptoPassed . Nonce8 . B.concat $ [constant, iv] + +-- | Increment a nonce +incrementNonce :: Nonce -> Nonce +incrementNonce (Nonce8 n) = Nonce8 $ incrementNonce' n 4 +incrementNonce (Nonce12 n) = Nonce12 $ incrementNonce' n 0 + +incrementNonce' :: Bytes -> Int -> Bytes +incrementNonce' b offset = B.copyAndFreeze b $ \s -> + loop s (s `plusPtr` offset) + where + loop :: Ptr Word8 -> Ptr Word8 -> IO () + loop s p + | s == (p `plusPtr` (B.length b - offset - 1)) = peek s >>= poke s . (+) 1 + | otherwise = do + r <- (+) 1 <$> peek p + poke p r + when (r == 0) $ loop s (p `plusPtr` 1) + +-- | Initialize a new ChaChaPoly1305 State +-- +-- The key length need to be 256 bits, and the nonce +-- procured using either `nonce8` or `nonce12` +initialize :: ByteArrayAccess key + => key -> Nonce -> CryptoFailable State +initialize key (Nonce8 nonce) = initialize' key nonce +initialize key (Nonce12 nonce) = initialize' key nonce + +initialize' :: ByteArrayAccess key + => key -> Bytes -> CryptoFailable State +initialize' key nonce + | B.length key /= 32 = CryptoFailed CryptoError_KeySizeInvalid + | otherwise = CryptoPassed $ State encState polyState 0 0 + where + rootState = ChaCha.initialize 20 key nonce + (polyKey, encState) = ChaCha.generate rootState 64 + polyState = throwCryptoError $ Poly1305.initialize (B.take 32 polyKey :: ScrubbedBytes) + +-- | Append Authenticated Data to the State and return +-- the new modified State. +-- +-- Once no further call to this function need to be make, +-- the user should call 'finalizeAAD' +appendAAD :: ByteArrayAccess ba => ba -> State -> State +appendAAD ba (State encState macState aadLength plainLength) = + State encState newMacState newLength plainLength + where + newMacState = Poly1305.update macState ba + newLength = aadLength + fromIntegral (B.length ba) + +-- | Finalize the Authenticated Data and return the finalized State +finalizeAAD :: State -> State +finalizeAAD (State encState macState aadLength plainLength) = + State encState newMacState aadLength plainLength + where + newMacState = Poly1305.update macState $ pad16 aadLength + +-- | Encrypt a piece of data and returns the encrypted Data and the +-- updated State. +encrypt :: ByteArray ba => ba -> State -> (ba, State) +encrypt input (State encState macState aadLength plainLength) = + (output, State newEncState newMacState aadLength newPlainLength) + where + (output, newEncState) = ChaCha.combine encState input + newMacState = Poly1305.update macState output + newPlainLength = plainLength + fromIntegral (B.length input) + +-- | Decrypt a piece of data and returns the decrypted Data and the +-- updated State. +decrypt :: ByteArray ba => ba -> State -> (ba, State) +decrypt input (State encState macState aadLength plainLength) = + (output, State newEncState newMacState aadLength newPlainLength) + where + (output, newEncState) = ChaCha.combine encState input + newMacState = Poly1305.update macState input + newPlainLength = plainLength + fromIntegral (B.length input) + +-- | Generate an authentication tag from the State. +finalize :: State -> Poly1305.Auth +finalize (State _ macState aadLength plainLength) = + Poly1305.finalize $ Poly1305.updates macState + [ pad16 plainLength + , either (error "finalize: internal error") id $ P.fill 16 (P.putStorable (toLE aadLength) >> P.putStorable (toLE plainLength)) + ] diff --git a/bundled/Crypto/Cipher/DES.hs b/bundled/Crypto/Cipher/DES.hs new file mode 100644 index 0000000..028a6ad --- /dev/null +++ b/bundled/Crypto/Cipher/DES.hs @@ -0,0 +1,39 @@ +-- | +-- Module : Crypto.Cipher.DES +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : good +-- +module Crypto.Cipher.DES + ( DES + ) where + +import Data.Word +import Crypto.Error +import Crypto.Cipher.Types +import Crypto.Cipher.DES.Primitive +import Crypto.Internal.ByteArray (ByteArrayAccess) +import qualified Crypto.Internal.ByteArray as B +import Data.Memory.Endian + +-- | DES Context +data DES = DES Word64 + deriving (Eq) + +instance Cipher DES where + cipherName _ = "DES" + cipherKeySize _ = KeySizeFixed 8 + cipherInit k = initDES k + +instance BlockCipher DES where + blockSize _ = 8 + ecbEncrypt (DES key) = B.mapAsWord64 (unBlock . encrypt key . Block) + ecbDecrypt (DES key) = B.mapAsWord64 (unBlock . decrypt key . Block) + +initDES :: ByteArrayAccess key => key -> CryptoFailable DES +initDES k + | len == 8 = CryptoPassed $ DES key + | otherwise = CryptoFailed $ CryptoError_KeySizeInvalid + where len = B.length k + key = fromBE $ B.toW64BE k 0 diff --git a/bundled/Crypto/Cipher/DES/Primitive.hs b/bundled/Crypto/Cipher/DES/Primitive.hs new file mode 100644 index 0000000..90c86a3 --- /dev/null +++ b/bundled/Crypto/Cipher/DES/Primitive.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE FlexibleInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Crypto.Cipher.DES.Primitive +-- License : BSD-style +-- +-- This module is copy of DES module from Crypto package. +-- http://hackage.haskell.org/package/Crypto +-- +----------------------------------------------------------------------------- + + +module Crypto.Cipher.DES.Primitive + ( encrypt + , decrypt + , Block(..) + ) where + +import Data.Word +import Data.Bits + +-- | a DES block (64 bits) +newtype Block = Block { unBlock :: Word64 } + +type Rotation = Int +type Key = Word64 + +type Bits4 = [Bool] +type Bits6 = [Bool] +type Bits32 = [Bool] +type Bits48 = [Bool] +type Bits56 = [Bool] +type Bits64 = [Bool] + +desXor :: [Bool] -> [Bool] -> [Bool] +desXor a b = zipWith (/=) a b + +desRotate :: [Bool] -> Int -> [Bool] +desRotate bits rot = drop rot' bits ++ take rot' bits + where rot' = rot `mod` length bits + +bitify :: Word64 -> Bits64 +bitify w = map (\b -> w .&. (shiftL 1 b) /= 0) [63,62..0] + +unbitify :: Bits64 -> Word64 +unbitify bs = foldl (\i b -> if b then 1 + shiftL i 1 else shiftL i 1) 0 bs + +initial_permutation :: Bits64 -> Bits64 +initial_permutation mb = map ((!!) mb) i + where i = [57, 49, 41, 33, 25, 17, 9, 1, 59, 51, 43, 35, 27, 19, 11, 3, + 61, 53, 45, 37, 29, 21, 13, 5, 63, 55, 47, 39, 31, 23, 15, 7, + 56, 48, 40, 32, 24, 16, 8, 0, 58, 50, 42, 34, 26, 18, 10, 2, + 60, 52, 44, 36, 28, 20, 12, 4, 62, 54, 46, 38, 30, 22, 14, 6] + +{- +"\x39\x31\x29\x21\x19\x11\x09\x01\x3b\x33\x2b\x23\x1b\x13\ +\\x0b\x03\x3d\x35\x2d\x25\x1d\x15\x0d\x05\x3f\x37\x2f\x27\ +\\x1f\x17\x0f\x07\x38\x30\x28\x20\x18\x10\x08\x00\x3a\x32\ +\\x2a\x22\x1a\x12\x0a\x02\x3c\x34\x2c\x24\x1c\x14\x0c\x04\ +\\x3e\x36\x2e\x26\x1e\x16\x0e\x06" +-} + +key_transformation :: Bits64 -> Bits56 +key_transformation kb = map ((!!) kb) i + where i = [56, 48, 40, 32, 24, 16, 8, 0, 57, 49, 41, 33, 25, 17, + 9, 1, 58, 50, 42, 34, 26, 18, 10, 2, 59, 51, 43, 35, + 62, 54, 46, 38, 30, 22, 14, 6, 61, 53, 45, 37, 29, 21, + 13, 5, 60, 52, 44, 36, 28, 20, 12, 4, 27, 19, 11, 3] +{- +"\x38\x30\x28\x20\x18\x10\x08\x00\x39\x31\x29\x21\x19\x11\ +\\x09\x01\x3a\x32\x2a\x22\x1a\x12\x0a\x02\x3b\x33\x2b\x23\ +\\x3e\x36\x2e\x26\x1e\x16\x0e\x06\x3d\x35\x2d\x25\x1d\x15\ +\\x0d\x05\x3c\x34\x2c\x24\x1c\x14\x0c\x04\x1b\x13\x0b\x03" +-} + + +des_enc :: Block -> Key -> Block +des_enc = do_des [1,2,4,6,8,10,12,14,15,17,19,21,23,25,27,28] + +des_dec :: Block -> Key -> Block +des_dec = do_des [28,27,25,23,21,19,17,15,14,12,10,8,6,4,2,1] + +do_des :: [Rotation] -> Block -> Key -> Block +do_des rots (Block m) k = Block $ des_work rots (takeDrop 32 mb) kb + where kb = key_transformation $ bitify k + mb = initial_permutation $ bitify m + +des_work :: [Rotation] -> (Bits32, Bits32) -> Bits56 -> Word64 +des_work [] (ml, mr) _ = unbitify $ final_perm $ (mr ++ ml) +des_work (r:rs) mb kb = des_work rs mb' kb + where mb' = do_round r mb kb + +do_round :: Rotation -> (Bits32, Bits32) -> Bits56 -> (Bits32, Bits32) +do_round r (ml, mr) kb = (mr, m') + where kb' = get_key kb r + comp_kb = compression_permutation kb' + expa_mr = expansion_permutation mr + res = comp_kb `desXor` expa_mr + res' = tail $ iterate (trans 6) ([], res) + trans n (_, b) = (take n b, drop n b) + res_s = concat $ zipWith (\f (x,_) -> f x) [s_box_1, s_box_2, + s_box_3, s_box_4, + s_box_5, s_box_6, + s_box_7, s_box_8] res' + res_p = p_box res_s + m' = res_p `desXor` ml + +get_key :: Bits56 -> Rotation -> Bits56 +get_key kb r = kb' + where (kl, kr) = takeDrop 28 kb + kb' = desRotate kl r ++ desRotate kr r + +compression_permutation :: Bits56 -> Bits48 +compression_permutation kb = map ((!!) kb) i + where i = [13, 16, 10, 23, 0, 4, 2, 27, 14, 5, 20, 9, + 22, 18, 11, 3, 25, 7, 15, 6, 26, 19, 12, 1, + 40, 51, 30, 36, 46, 54, 29, 39, 50, 44, 32, 47, + 43, 48, 38, 55, 33, 52, 45, 41, 49, 35, 28, 31] + +expansion_permutation :: Bits32 -> Bits48 +expansion_permutation mb = map ((!!) mb) i + where i = [31, 0, 1, 2, 3, 4, 3, 4, 5, 6, 7, 8, + 7, 8, 9, 10, 11, 12, 11, 12, 13, 14, 15, 16, + 15, 16, 17, 18, 19, 20, 19, 20, 21, 22, 23, 24, + 23, 24, 25, 26, 27, 28, 27, 28, 29, 30, 31, 0] + +s_box :: [[Word8]] -> Bits6 -> Bits4 +s_box s [a,b,c,d,e,f] = to_bool 4 $ (s !! row) !! col + where row = sum $ zipWith numericise [a,f] [1, 0] + col = sum $ zipWith numericise [b,c,d,e] [3, 2, 1, 0] + numericise :: Bool -> Int -> Int + numericise = (\x y -> if x then 2^y else 0) + + to_bool :: Int -> Word8 -> [Bool] + to_bool 0 _ = [] + to_bool n i = ((i .&. 8) == 8):to_bool (n-1) (shiftL i 1) +s_box _ _ = error "DES: internal error bits6 more than 6 elements" + +s_box_1 :: Bits6 -> Bits4 +s_box_1 = s_box i + where i = [[14, 4, 13, 1, 2, 15, 11, 8, 3, 10, 6, 12, 5, 9, 0, 7], + [ 0, 15, 7, 4, 14, 2, 13, 1, 10, 6, 12, 11, 9, 5, 3, 8], + [ 4, 1, 14, 8, 13, 6, 2, 11, 15, 12, 9, 7, 3, 10, 5, 0], + [15, 12, 8, 2, 4, 9, 1, 7, 5, 11, 3, 14, 10, 0, 6, 13]] + +s_box_2 :: Bits6 -> Bits4 +s_box_2 = s_box i + where i = [[15, 1, 8, 14, 6, 11, 3, 4, 9, 7, 2, 13, 12, 0, 5, 10], + [3, 13, 4, 7, 15, 2, 8, 14, 12, 0, 1, 10, 6, 9, 11, 5], + [0, 14, 7, 11, 10, 4, 13, 1, 5, 8, 12, 6, 9, 3, 2, 15], + [13, 8, 10, 1, 3, 15, 4, 2, 11, 6, 7, 12, 0, 5, 14, 9]] + +s_box_3 :: Bits6 -> Bits4 +s_box_3 = s_box i + where i = [[10, 0, 9, 14 , 6, 3, 15, 5, 1, 13, 12, 7, 11, 4, 2, 8], + [13, 7, 0, 9, 3, 4, 6, 10, 2, 8, 5, 14, 12, 11, 15, 1], + [13, 6, 4, 9, 8, 15, 3, 0, 11, 1, 2, 12, 5, 10, 14, 7], + [1, 10, 13, 0, 6, 9, 8, 7, 4, 15, 14, 3, 11, 5, 2, 12]] + +s_box_4 :: Bits6 -> Bits4 +s_box_4 = s_box i + where i = [[7, 13, 14, 3, 0, 6, 9, 10, 1, 2, 8, 5, 11, 12, 4, 15], + [13, 8, 11, 5, 6, 15, 0, 3, 4, 7, 2, 12, 1, 10, 14, 9], + [10, 6, 9, 0, 12, 11, 7, 13, 15, 1, 3, 14, 5, 2, 8, 4], + [3, 15, 0, 6, 10, 1, 13, 8, 9, 4, 5, 11, 12, 7, 2, 14]] + +s_box_5 :: Bits6 -> Bits4 +s_box_5 = s_box i + where i = [[2, 12, 4, 1, 7, 10, 11, 6, 8, 5, 3, 15, 13, 0, 14, 9], + [14, 11, 2, 12, 4, 7, 13, 1, 5, 0, 15, 10, 3, 9, 8, 6], + [4, 2, 1, 11, 10, 13, 7, 8, 15, 9, 12, 5, 6, 3, 0, 14], + [11, 8, 12, 7, 1, 14, 2, 13, 6, 15, 0, 9, 10, 4, 5, 3]] + +s_box_6 :: Bits6 -> Bits4 +s_box_6 = s_box i + where i = [[12, 1, 10, 15, 9, 2, 6, 8, 0, 13, 3, 4, 14, 7, 5, 11], + [10, 15, 4, 2, 7, 12, 9, 5, 6, 1, 13, 14, 0, 11, 3, 8], + [9, 14, 15, 5, 2, 8, 12, 3, 7, 0, 4, 10, 1, 13, 11, 6], + [4, 3, 2, 12, 9, 5, 15, 10, 11, 14, 1, 7, 6, 0, 8, 13]] + +s_box_7 :: Bits6 -> Bits4 +s_box_7 = s_box i + where i = [[4, 11, 2, 14, 15, 0, 8, 13, 3, 12, 9, 7, 5, 10, 6, 1], + [13, 0, 11, 7, 4, 9, 1, 10, 14, 3, 5, 12, 2, 15, 8, 6], + [1, 4, 11, 13, 12, 3, 7, 14, 10, 15, 6, 8, 0, 5, 9, 2], + [6, 11, 13, 8, 1, 4, 10, 7, 9, 5, 0, 15, 14, 2, 3, 12]] + +s_box_8 :: Bits6 -> Bits4 +s_box_8 = s_box i + where i = [[13, 2, 8, 4, 6, 15, 11, 1, 10, 9, 3, 14, 5, 0, 12, 7], + [1, 15, 13, 8, 10, 3, 7, 4, 12, 5, 6, 11, 0, 14, 9, 2], + [7, 11, 4, 1, 9, 12, 14, 2, 0, 6, 10, 13, 15, 3, 5, 8], + [2, 1, 14, 7, 4, 10, 8, 13, 15, 12, 9, 0, 3, 5, 6, 11]] + +p_box :: Bits32 -> Bits32 +p_box kb = map ((!!) kb) i + where i = [15, 6, 19, 20, 28, 11, 27, 16, 0, 14, 22, 25, 4, 17, 30, 9, + 1, 7, 23, 13, 31, 26, 2, 8, 18, 12, 29, 5, 21, 10, 3, 24] + +final_perm :: Bits64 -> Bits64 +final_perm kb = map ((!!) kb) i + where i = [39, 7, 47, 15, 55, 23, 63, 31, 38, 6, 46, 14, 54, 22, 62, 30, + 37, 5, 45, 13, 53, 21, 61, 29, 36, 4, 44, 12, 52, 20, 60, 28, + 35, 3, 43, 11, 51, 19, 59, 27, 34, 2, 42, 10, 50, 18, 58, 26, + 33, 1, 41, 9, 49, 17, 57, 25, 32, 0, 40 , 8, 48, 16, 56, 24] + +takeDrop :: Int -> [a] -> ([a], [a]) +takeDrop _ [] = ([], []) +takeDrop 0 xs = ([], xs) +takeDrop n (x:xs) = (x:ys, zs) + where (ys, zs) = takeDrop (n-1) xs + + +-- | Basic DES encryption which takes a key and a block of plaintext +-- and returns the encrypted block of ciphertext according to the standard. +encrypt :: Word64 -> Block -> Block +encrypt = flip des_enc + +-- | Basic DES decryption which takes a key and a block of ciphertext and +-- returns the decrypted block of plaintext according to the standard. +decrypt :: Word64 -> Block -> Block +decrypt = flip des_dec diff --git a/bundled/Crypto/Cipher/RC4.hs b/bundled/Crypto/Cipher/RC4.hs new file mode 100644 index 0000000..b6de2ce --- /dev/null +++ b/bundled/Crypto/Cipher/RC4.hs @@ -0,0 +1,84 @@ +-- | +-- Module : Crypto.Cipher.RC4 +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +-- Simple implementation of the RC4 stream cipher. +-- http://en.wikipedia.org/wiki/RC4 +-- +-- Initial FFI implementation by Peter White +-- +-- Reorganized and simplified to have an opaque context. +-- +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Crypto.Cipher.RC4 + ( initialize + , combine + , generate + , State + ) where + +import Data.Word +import Foreign.Ptr +import Crypto.Internal.ByteArray (ScrubbedBytes, ByteArray, ByteArrayAccess) +import qualified Crypto.Internal.ByteArray as B + +import Crypto.Internal.Compat +import Crypto.Internal.Imports + +-- | The encryption state for RC4 +-- +-- This type is an instance of 'ByteArrayAccess' for debugging purpose. Internal +-- layout is architecture dependent, may contain uninitialized data fragments, +-- and change in future versions. The bytearray should not be used as input to +-- cryptographic algorithms. +newtype State = State ScrubbedBytes + deriving (ByteArrayAccess,NFData) + +-- | C Call for initializing the encryptor +foreign import ccall unsafe "cryptonite_rc4.h cryptonite_rc4_init" + c_rc4_init :: Ptr Word8 -- ^ The rc4 key + -> Word32 -- ^ The key length + -> Ptr State -- ^ The context + -> IO () + +foreign import ccall unsafe "cryptonite_rc4.h cryptonite_rc4_combine" + c_rc4_combine :: Ptr State -- ^ Pointer to the permutation + -> Ptr Word8 -- ^ Pointer to the clear text + -> Word32 -- ^ Length of the clear text + -> Ptr Word8 -- ^ Output buffer + -> IO () + +-- | RC4 context initialization. +-- +-- seed the context with an initial key. the key size need to be +-- adequate otherwise security takes a hit. +initialize :: ByteArrayAccess key + => key -- ^ The key + -> State -- ^ The RC4 context with the key mixed in +initialize key = unsafeDoIO $ do + st <- B.alloc 264 $ \stPtr -> + B.withByteArray key $ \keyPtr -> c_rc4_init keyPtr (fromIntegral $ B.length key) (castPtr stPtr) + return $ State st + +-- | generate the next len bytes of the rc4 stream without combining +-- it to anything. +generate :: ByteArray ba => State -> Int -> (State, ba) +generate ctx len = combine ctx (B.zero len) + +-- | RC4 xor combination of the rc4 stream with an input +combine :: ByteArray ba + => State -- ^ rc4 context + -> ba -- ^ input + -> (State, ba) -- ^ new rc4 context, and the output +combine (State prevSt) clearText = unsafeDoIO $ + B.allocRet len $ \outptr -> + B.withByteArray clearText $ \clearPtr -> do + st <- B.copy prevSt $ \stPtr -> + c_rc4_combine (castPtr stPtr) clearPtr (fromIntegral len) outptr + return $! State st + --return $! (State st, B.PS outfptr 0 len) + where len = B.length clearText diff --git a/bundled/Crypto/Cipher/Salsa.hs b/bundled/Crypto/Cipher/Salsa.hs new file mode 100644 index 0000000..34cd7b7 --- /dev/null +++ b/bundled/Crypto/Cipher/Salsa.hs @@ -0,0 +1,83 @@ +-- | +-- Module : Crypto.Cipher.Salsa +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : good +-- +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Crypto.Cipher.Salsa + ( initialize + , combine + , generate + , State(..) + ) where + +import Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, ScrubbedBytes) +import qualified Crypto.Internal.ByteArray as B +import Crypto.Internal.Compat +import Crypto.Internal.Imports +import Foreign.Ptr +import Foreign.C.Types + +-- | Salsa context +newtype State = State ScrubbedBytes + deriving (NFData) + +-- | Initialize a new Salsa context with the number of rounds, +-- the key and the nonce associated. +initialize :: (ByteArrayAccess key, ByteArrayAccess nonce) + => Int -- ^ number of rounds (8,12,20) + -> key -- ^ the key (128 or 256 bits) + -> nonce -- ^ the nonce (64 or 96 bits) + -> State -- ^ the initial Salsa state +initialize nbRounds key nonce + | kLen `notElem` [16,32] = error "Salsa: key length should be 128 or 256 bits" + | nonceLen `notElem` [8,12] = error "Salsa: nonce length should be 64 or 96 bits" + | nbRounds `notElem` [8,12,20] = error "Salsa: rounds should be 8, 12 or 20" + | otherwise = unsafeDoIO $ do + stPtr <- B.alloc 132 $ \stPtr -> + B.withByteArray nonce $ \noncePtr -> + B.withByteArray key $ \keyPtr -> + ccryptonite_salsa_init stPtr nbRounds kLen keyPtr nonceLen noncePtr + return $ State stPtr + where kLen = B.length key + nonceLen = B.length nonce + +-- | Combine the salsa output and an arbitrary message with a xor, +-- and return the combined output and the new state. +combine :: ByteArray ba + => State -- ^ the current Salsa state + -> ba -- ^ the source to xor with the generator + -> (ba, State) +combine prevSt@(State prevStMem) src + | B.null src = (B.empty, prevSt) + | otherwise = unsafeDoIO $ do + (out, st) <- B.copyRet prevStMem $ \ctx -> + B.alloc (B.length src) $ \dstPtr -> + B.withByteArray src $ \srcPtr -> do + ccryptonite_salsa_combine dstPtr ctx srcPtr (fromIntegral $ B.length src) + return (out, State st) + +-- | Generate a number of bytes from the Salsa output directly +generate :: ByteArray ba + => State -- ^ the current Salsa state + -> Int -- ^ the length of data to generate + -> (ba, State) +generate prevSt@(State prevStMem) len + | len <= 0 = (B.empty, prevSt) + | otherwise = unsafeDoIO $ do + (out, st) <- B.copyRet prevStMem $ \ctx -> + B.alloc len $ \dstPtr -> + ccryptonite_salsa_generate dstPtr ctx (fromIntegral len) + return (out, State st) + +foreign import ccall "cryptonite_salsa_init" + ccryptonite_salsa_init :: Ptr State -> Int -> Int -> Ptr Word8 -> Int -> Ptr Word8 -> IO () + +foreign import ccall "cryptonite_salsa_combine" + ccryptonite_salsa_combine :: Ptr Word8 -> Ptr State -> Ptr Word8 -> CUInt -> IO () + +foreign import ccall "cryptonite_salsa_generate" + ccryptonite_salsa_generate :: Ptr Word8 -> Ptr State -> CUInt -> IO () diff --git a/bundled/Crypto/Cipher/TripleDES.hs b/bundled/Crypto/Cipher/TripleDES.hs new file mode 100644 index 0000000..581fa8f --- /dev/null +++ b/bundled/Crypto/Cipher/TripleDES.hs @@ -0,0 +1,90 @@ +-- | +-- Module : Crypto.Cipher.TripleDES +-- License : BSD-style +-- Stability : experimental +-- Portability : ??? + +module Crypto.Cipher.TripleDES + ( DES_EEE3 + , DES_EDE3 + , DES_EEE2 + , DES_EDE2 + ) where + +import Data.Word +import Crypto.Error +import Crypto.Cipher.Types +import Crypto.Cipher.DES.Primitive +import Crypto.Internal.ByteArray (ByteArrayAccess) +import qualified Crypto.Internal.ByteArray as B +import Data.Memory.Endian + +-- | 3DES with 3 different keys used all in the same direction +data DES_EEE3 = DES_EEE3 Word64 Word64 Word64 + deriving (Eq) + +-- | 3DES with 3 different keys used in alternative direction +data DES_EDE3 = DES_EDE3 Word64 Word64 Word64 + deriving (Eq) + +-- | 3DES where the first and third keys are equal, used in the same direction +data DES_EEE2 = DES_EEE2 Word64 Word64 -- key1 and key3 are equal + deriving (Eq) + +-- | 3DES where the first and third keys are equal, used in alternative direction +data DES_EDE2 = DES_EDE2 Word64 Word64 -- key1 and key3 are equal + deriving (Eq) + +instance Cipher DES_EEE3 where + cipherName _ = "3DES_EEE" + cipherKeySize _ = KeySizeFixed 24 + cipherInit k = init3DES DES_EEE3 k + +instance Cipher DES_EDE3 where + cipherName _ = "3DES_EDE" + cipherKeySize _ = KeySizeFixed 24 + cipherInit k = init3DES DES_EDE3 k + +instance Cipher DES_EDE2 where + cipherName _ = "2DES_EDE" + cipherKeySize _ = KeySizeFixed 16 + cipherInit k = init2DES DES_EDE2 k + +instance Cipher DES_EEE2 where + cipherName _ = "2DES_EEE" + cipherKeySize _ = KeySizeFixed 16 + cipherInit k = init2DES DES_EEE2 k + +instance BlockCipher DES_EEE3 where + blockSize _ = 8 + ecbEncrypt (DES_EEE3 k1 k2 k3) = B.mapAsWord64 (unBlock . (encrypt k3 . encrypt k2 . encrypt k1) . Block) + ecbDecrypt (DES_EEE3 k1 k2 k3) = B.mapAsWord64 (unBlock . (decrypt k1 . decrypt k2 . decrypt k3) . Block) + +instance BlockCipher DES_EDE3 where + blockSize _ = 8 + ecbEncrypt (DES_EDE3 k1 k2 k3) = B.mapAsWord64 (unBlock . (encrypt k3 . decrypt k2 . encrypt k1) . Block) + ecbDecrypt (DES_EDE3 k1 k2 k3) = B.mapAsWord64 (unBlock . (decrypt k1 . encrypt k2 . decrypt k3) . Block) + +instance BlockCipher DES_EEE2 where + blockSize _ = 8 + ecbEncrypt (DES_EEE2 k1 k2) = B.mapAsWord64 (unBlock . (encrypt k1 . encrypt k2 . encrypt k1) . Block) + ecbDecrypt (DES_EEE2 k1 k2) = B.mapAsWord64 (unBlock . (decrypt k1 . decrypt k2 . decrypt k1) . Block) + +instance BlockCipher DES_EDE2 where + blockSize _ = 8 + ecbEncrypt (DES_EDE2 k1 k2) = B.mapAsWord64 (unBlock . (encrypt k1 . decrypt k2 . encrypt k1) . Block) + ecbDecrypt (DES_EDE2 k1 k2) = B.mapAsWord64 (unBlock . (decrypt k1 . encrypt k2 . decrypt k1) . Block) + +init3DES :: ByteArrayAccess key => (Word64 -> Word64 -> Word64 -> a) -> key -> CryptoFailable a +init3DES constr k + | len == 24 = CryptoPassed $ constr k1 k2 k3 + | otherwise = CryptoFailed CryptoError_KeySizeInvalid + where len = B.length k + (k1, k2, k3) = (fromBE $ B.toW64BE k 0, fromBE $ B.toW64BE k 8, fromBE $ B.toW64BE k 16) + +init2DES :: ByteArrayAccess key => (Word64 -> Word64 -> a) -> key -> CryptoFailable a +init2DES constr k + | len == 16 = CryptoPassed $ constr k1 k2 + | otherwise = CryptoFailed CryptoError_KeySizeInvalid + where len = B.length k + (k1, k2) = (fromBE $ B.toW64BE k 0, fromBE $ B.toW64BE k 8) diff --git a/bundled/Crypto/Cipher/Twofish.hs b/bundled/Crypto/Cipher/Twofish.hs new file mode 100644 index 0000000..7fedd0e --- /dev/null +++ b/bundled/Crypto/Cipher/Twofish.hs @@ -0,0 +1,45 @@ +module Crypto.Cipher.Twofish + ( Twofish128 + , Twofish192 + , Twofish256 + ) where + +import Crypto.Cipher.Twofish.Primitive +import Crypto.Cipher.Types +import Crypto.Cipher.Utils + +newtype Twofish128 = Twofish128 Twofish + +instance Cipher Twofish128 where + cipherName _ = "Twofish128" + cipherKeySize _ = KeySizeFixed 16 + cipherInit key = Twofish128 <$> (initTwofish =<< validateKeySize (undefined :: Twofish128) key) + +instance BlockCipher Twofish128 where + blockSize _ = 16 + ecbEncrypt (Twofish128 key) = encrypt key + ecbDecrypt (Twofish128 key) = decrypt key + +newtype Twofish192 = Twofish192 Twofish + +instance Cipher Twofish192 where + cipherName _ = "Twofish192" + cipherKeySize _ = KeySizeFixed 24 + cipherInit key = Twofish192 <$> (initTwofish =<< validateKeySize (undefined :: Twofish192) key) + +instance BlockCipher Twofish192 where + blockSize _ = 16 + ecbEncrypt (Twofish192 key) = encrypt key + ecbDecrypt (Twofish192 key) = decrypt key + +newtype Twofish256 = Twofish256 Twofish + +instance Cipher Twofish256 where + cipherName _ = "Twofish256" + cipherKeySize _ = KeySizeFixed 32 + cipherInit key = Twofish256 <$> (initTwofish =<< validateKeySize (undefined :: Twofish256) key) + +instance BlockCipher Twofish256 where + blockSize _ = 16 + ecbEncrypt (Twofish256 key) = encrypt key + ecbDecrypt (Twofish256 key) = decrypt key diff --git a/bundled/Crypto/Cipher/Twofish/Primitive.hs b/bundled/Crypto/Cipher/Twofish/Primitive.hs new file mode 100644 index 0000000..30c260d --- /dev/null +++ b/bundled/Crypto/Cipher/Twofish/Primitive.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +module Crypto.Cipher.Twofish.Primitive + ( Twofish + , initTwofish + , encrypt + , decrypt + ) where + +import Crypto.Error +import Crypto.Internal.ByteArray (ByteArray) +import qualified Crypto.Internal.ByteArray as B +import Crypto.Internal.WordArray +import Data.Word +import Data.Bits +import Data.List + +-- Based on the Golang referance implementation +-- https://github.com/golang/crypto/blob/master/twofish/twofish.go + + +-- BlockSize is the constant block size of Twofish. +blockSize :: Int +blockSize = 16 + +mdsPolynomial, rsPolynomial :: Word32 +mdsPolynomial = 0x169 -- x^8 + x^6 + x^5 + x^3 + 1, see [TWOFISH] 4.2 +rsPolynomial = 0x14d -- x^8 + x^6 + x^3 + x^2 + 1, see [TWOFISH] 4.3 + +data Twofish = Twofish { s :: (Array32, Array32, Array32, Array32) + , k :: Array32 } + +data ByteSize = Bytes16 | Bytes24 | Bytes32 deriving (Eq) + +data KeyPackage ba = KeyPackage { rawKeyBytes :: ba + , byteSize :: ByteSize } + +buildPackage :: ByteArray ba => ba -> Maybe (KeyPackage ba) +buildPackage key + | B.length key == 16 = return $ KeyPackage key Bytes16 + | B.length key == 24 = return $ KeyPackage key Bytes24 + | B.length key == 32 = return $ KeyPackage key Bytes32 + | otherwise = Nothing + +-- | Initialize a 128-bit, 192-bit, or 256-bit key +-- +-- Return the initialized key or a error message if the given +-- keyseed was not 16-bytes in length. +initTwofish :: ByteArray key + => key -- ^ The key to create the twofish context + -> CryptoFailable Twofish +initTwofish key = + case buildPackage key of Nothing -> CryptoFailed CryptoError_KeySizeInvalid + Just keyPackage -> CryptoPassed Twofish { k = generatedK, s = generatedS } + where generatedK = array32 40 $ genK keyPackage + generatedS = genSboxes keyPackage $ sWords key + +mapBlocks :: ByteArray ba => (ba -> ba) -> ba -> ba +mapBlocks operation input + | B.null rest = blockOutput + | otherwise = blockOutput `B.append` mapBlocks operation rest + where (block, rest) = B.splitAt blockSize input + blockOutput = operation block + +-- | Encrypts the given ByteString using the given Key +encrypt :: ByteArray ba + => Twofish -- ^ The key to use + -> ba -- ^ The data to encrypt + -> ba +encrypt cipher = mapBlocks (encryptBlock cipher) + +encryptBlock :: ByteArray ba => Twofish -> ba -> ba +encryptBlock Twofish { s = (s1, s2, s3, s4), k = ks } message = store32ls ts + where (a, b, c, d) = load32ls message + a' = a `xor` arrayRead32 ks 0 + b' = b `xor` arrayRead32 ks 1 + c' = c `xor` arrayRead32 ks 2 + d' = d `xor` arrayRead32 ks 3 + (!a'', !b'', !c'', !d'') = foldl' shuffle (a', b', c', d') [0..7] + ts = (c'' `xor` arrayRead32 ks 4, d'' `xor` arrayRead32 ks 5, a'' `xor` arrayRead32 ks 6, b'' `xor` arrayRead32 ks 7) + + shuffle :: (Word32, Word32, Word32, Word32) -> Int -> (Word32, Word32, Word32, Word32) + shuffle (!retA, !retB, !retC, !retD) ind = (retA', retB', retC', retD') + where [k0, k1, k2, k3] = fmap (\offset -> arrayRead32 ks $ (8 + 4 * ind) + offset) [0..3] + t2 = byteIndex s2 retB `xor` byteIndex s3 (shiftR retB 8) `xor` byteIndex s4 (shiftR retB 16) `xor` byteIndex s1 (shiftR retB 24) + t1 = (byteIndex s1 retA `xor` byteIndex s2 (shiftR retA 8) `xor` byteIndex s3 (shiftR retA 16) `xor` byteIndex s4 (shiftR retA 24)) + t2 + retC' = rotateR (retC `xor` (t1 + k0)) 1 + retD' = rotateL retD 1 `xor` (t1 + t2 + k1) + t2' = byteIndex s2 retD' `xor` byteIndex s3 (shiftR retD' 8) `xor` byteIndex s4 (shiftR retD' 16) `xor` byteIndex s1 (shiftR retD' 24) + t1' = (byteIndex s1 retC' `xor` byteIndex s2 (shiftR retC' 8) `xor` byteIndex s3 (shiftR retC' 16) `xor` byteIndex s4 (shiftR retC' 24)) + t2' + retA' = rotateR (retA `xor` (t1' + k2)) 1 + retB' = rotateL retB 1 `xor` (t1' + t2' + k3) + +-- Unsafe, no bounds checking +byteIndex :: Array32 -> Word32 -> Word32 +byteIndex xs ind = arrayRead32 xs $ fromIntegral byte + where byte = ind `mod` 256 + +-- | Decrypts the given ByteString using the given Key +decrypt :: ByteArray ba + => Twofish -- ^ The key to use + -> ba -- ^ The data to decrypt + -> ba +decrypt cipher = mapBlocks (decryptBlock cipher) + +{- decryption for 128 bits blocks -} +decryptBlock :: ByteArray ba => Twofish -> ba -> ba +decryptBlock Twofish { s = (s1, s2, s3, s4), k = ks } message = store32ls ixs + where (a, b, c, d) = load32ls message + a' = c `xor` arrayRead32 ks 6 + b' = d `xor` arrayRead32 ks 7 + c' = a `xor` arrayRead32 ks 4 + d' = b `xor` arrayRead32 ks 5 + (!a'', !b'', !c'', !d'') = foldl' unshuffle (a', b', c', d') [8, 7..1] + ixs = (a'' `xor` arrayRead32 ks 0, b'' `xor` arrayRead32 ks 1, c'' `xor` arrayRead32 ks 2, d'' `xor` arrayRead32 ks 3) + + unshuffle :: (Word32, Word32, Word32, Word32) -> Int -> (Word32, Word32, Word32, Word32) + unshuffle (!retA, !retB, !retC, !retD) ind = (retA', retB', retC', retD') + where [k0, k1, k2, k3] = fmap (\offset -> arrayRead32 ks $ (4 + 4 * ind) + offset) [0..3] + t2 = byteIndex s2 retD `xor` byteIndex s3 (shiftR retD 8) `xor` byteIndex s4 (shiftR retD 16) `xor` byteIndex s1 (shiftR retD 24) + t1 = (byteIndex s1 retC `xor` byteIndex s2 (shiftR retC 8) `xor` byteIndex s3 (shiftR retC 16) `xor` byteIndex s4 (shiftR retC 24)) + t2 + retA' = rotateL retA 1 `xor` (t1 + k2) + retB' = rotateR (retB `xor` (t2 + t1 + k3)) 1 + t2' = byteIndex s2 retB' `xor` byteIndex s3 (shiftR retB' 8) `xor` byteIndex s4 (shiftR retB' 16) `xor` byteIndex s1 (shiftR retB' 24) + t1' = (byteIndex s1 retA' `xor` byteIndex s2 (shiftR retA' 8) `xor` byteIndex s3 (shiftR retA' 16) `xor` byteIndex s4 (shiftR retA' 24)) + t2' + retC' = rotateL retC 1 `xor` (t1' + k0) + retD' = rotateR (retD `xor` (t2' + t1' + k1)) 1 + +sbox0 :: Int -> Word8 +sbox0 = arrayRead8 t + where t = array8 + "\xa9\x67\xb3\xe8\x04\xfd\xa3\x76\x9a\x92\x80\x78\xe4\xdd\xd1\x38\ + \\x0d\xc6\x35\x98\x18\xf7\xec\x6c\x43\x75\x37\x26\xfa\x13\x94\x48\ + \\xf2\xd0\x8b\x30\x84\x54\xdf\x23\x19\x5b\x3d\x59\xf3\xae\xa2\x82\ + \\x63\x01\x83\x2e\xd9\x51\x9b\x7c\xa6\xeb\xa5\xbe\x16\x0c\xe3\x61\ + \\xc0\x8c\x3a\xf5\x73\x2c\x25\x0b\xbb\x4e\x89\x6b\x53\x6a\xb4\xf1\ + \\xe1\xe6\xbd\x45\xe2\xf4\xb6\x66\xcc\x95\x03\x56\xd4\x1c\x1e\xd7\ + \\xfb\xc3\x8e\xb5\xe9\xcf\xbf\xba\xea\x77\x39\xaf\x33\xc9\x62\x71\ + \\x81\x79\x09\xad\x24\xcd\xf9\xd8\xe5\xc5\xb9\x4d\x44\x08\x86\xe7\ + \\xa1\x1d\xaa\xed\x06\x70\xb2\xd2\x41\x7b\xa0\x11\x31\xc2\x27\x90\ + \\x20\xf6\x60\xff\x96\x5c\xb1\xab\x9e\x9c\x52\x1b\x5f\x93\x0a\xef\ + \\x91\x85\x49\xee\x2d\x4f\x8f\x3b\x47\x87\x6d\x46\xd6\x3e\x69\x64\ + \\x2a\xce\xcb\x2f\xfc\x97\x05\x7a\xac\x7f\xd5\x1a\x4b\x0e\xa7\x5a\ + \\x28\x14\x3f\x29\x88\x3c\x4c\x02\xb8\xda\xb0\x17\x55\x1f\x8a\x7d\ + \\x57\xc7\x8d\x74\xb7\xc4\x9f\x72\x7e\x15\x22\x12\x58\x07\x99\x34\ + \\x6e\x50\xde\x68\x65\xbc\xdb\xf8\xc8\xa8\x2b\x40\xdc\xfe\x32\xa4\ + \\xca\x10\x21\xf0\xd3\x5d\x0f\x00\x6f\x9d\x36\x42\x4a\x5e\xc1\xe0"# + +sbox1 :: Int -> Word8 +sbox1 = arrayRead8 t + where t = array8 + "\x75\xf3\xc6\xf4\xdb\x7b\xfb\xc8\x4a\xd3\xe6\x6b\x45\x7d\xe8\x4b\ + \\xd6\x32\xd8\xfd\x37\x71\xf1\xe1\x30\x0f\xf8\x1b\x87\xfa\x06\x3f\ + \\x5e\xba\xae\x5b\x8a\x00\xbc\x9d\x6d\xc1\xb1\x0e\x80\x5d\xd2\xd5\ + \\xa0\x84\x07\x14\xb5\x90\x2c\xa3\xb2\x73\x4c\x54\x92\x74\x36\x51\ + \\x38\xb0\xbd\x5a\xfc\x60\x62\x96\x6c\x42\xf7\x10\x7c\x28\x27\x8c\ + \\x13\x95\x9c\xc7\x24\x46\x3b\x70\xca\xe3\x85\xcb\x11\xd0\x93\xb8\ + \\xa6\x83\x20\xff\x9f\x77\xc3\xcc\x03\x6f\x08\xbf\x40\xe7\x2b\xe2\ + \\x79\x0c\xaa\x82\x41\x3a\xea\xb9\xe4\x9a\xa4\x97\x7e\xda\x7a\x17\ + \\x66\x94\xa1\x1d\x3d\xf0\xde\xb3\x0b\x72\xa7\x1c\xef\xd1\x53\x3e\ + \\x8f\x33\x26\x5f\xec\x76\x2a\x49\x81\x88\xee\x21\xc4\x1a\xeb\xd9\ + \\xc5\x39\x99\xcd\xad\x31\x8b\x01\x18\x23\xdd\x1f\x4e\x2d\xf9\x48\ + \\x4f\xf2\x65\x8e\x78\x5c\x58\x19\x8d\xe5\x98\x57\x67\x7f\x05\x64\ + \\xaf\x63\xb6\xfe\xf5\xb7\x3c\xa5\xce\xe9\x68\x44\xe0\x4d\x43\x69\ + \\x29\x2e\xac\x15\x59\xa8\x0a\x9e\x6e\x47\xdf\x34\x35\x6a\xcf\xdc\ + \\x22\xc9\xc0\x9b\x89\xd4\xed\xab\x12\xa2\x0d\x52\xbb\x02\x2f\xa9\ + \\xd7\x61\x1e\xb4\x50\x04\xf6\xc2\x16\x25\x86\x56\x55\x09\xbe\x91"# + +rs :: [[Word8]] +rs = [ [0x01, 0xA4, 0x55, 0x87, 0x5A, 0x58, 0xDB, 0x9E] + , [0xA4, 0x56, 0x82, 0xF3, 0x1E, 0xC6, 0x68, 0xE5] + , [0x02, 0xA1, 0xFC, 0xC1, 0x47, 0xAE, 0x3D, 0x19] + , [0xA4, 0x55, 0x87, 0x5A, 0x58, 0xDB, 0x9E, 0x03] ] + + + +load32ls :: ByteArray ba => ba -> (Word32, Word32, Word32, Word32) +load32ls message = (intify q1, intify q2, intify q3, intify q4) + where (half1, half2) = B.splitAt 8 message + (q1, q2) = B.splitAt 4 half1 + (q3, q4) = B.splitAt 4 half2 + + intify :: ByteArray ba => ba -> Word32 + intify bytes = foldl' (\int (!word, !ind) -> int .|. shiftL (fromIntegral word) (ind * 8) ) 0 (zip (B.unpack bytes) [0..]) + +store32ls :: ByteArray ba => (Word32, Word32, Word32, Word32) -> ba +store32ls (a, b, c, d) = B.pack $ concatMap splitWordl [a, b, c, d] + where splitWordl :: Word32 -> [Word8] + splitWordl w = fmap (\ind -> fromIntegral $ shiftR w (8 * ind)) [0..3] + + +-- Create S words +sWords :: ByteArray ba => ba -> [Word8] +sWords key = sWord + where word64Count = B.length key `div` 2 + sWord = concatMap (\wordIndex -> + map (\rsRow -> + foldl' (\acc (!rsVal, !colIndex) -> + acc `xor` gfMult rsPolynomial (B.index key $ 8 * wordIndex + colIndex) rsVal + ) 0 (zip rsRow [0..]) + ) rs + ) [0..word64Count - 1] + +data Column = Zero | One | Two | Three deriving (Show, Eq, Enum, Bounded) + +genSboxes :: KeyPackage ba -> [Word8] -> (Array32, Array32, Array32, Array32) +genSboxes keyPackage ws = (mkArray b0', mkArray b1', mkArray b2', mkArray b3') + where range = [0..255] + mkArray = array32 256 + [w0, w1, w2, w3, w4, w5, w6, w7, w8, w9, w10, w11, w12, w13, w14, w15] = take 16 ws + (b0', b1', b2', b3') = sboxBySize $ byteSize keyPackage + + sboxBySize :: ByteSize -> ([Word32], [Word32], [Word32], [Word32]) + sboxBySize Bytes16 = (b0, b1, b2, b3) + where !b0 = fmap mapper range + where mapper :: Int -> Word32 + mapper byte = mdsColumnMult ((sbox1 . fromIntegral) ((sbox0 . fromIntegral $ sbox0 byte `xor` w0) `xor` w4)) Zero + !b1 = fmap mapper range + where mapper byte = mdsColumnMult ((sbox0 . fromIntegral) ((sbox0 . fromIntegral $ sbox1 byte `xor` w1) `xor` w5)) One + !b2 = fmap mapper range + where mapper byte = mdsColumnMult ((sbox1 . fromIntegral) ((sbox1 . fromIntegral $ sbox0 byte `xor` w2) `xor` w6)) Two + !b3 = fmap mapper range + where mapper byte = mdsColumnMult ((sbox0 . fromIntegral) ((sbox1 . fromIntegral $ sbox1 byte `xor` w3) `xor` w7)) Three + + sboxBySize Bytes24 = (b0, b1, b2, b3) + where !b0 = fmap mapper range + where mapper byte = mdsColumnMult ((sbox1 . fromIntegral) ((sbox0 . fromIntegral) ((sbox0 . fromIntegral $ sbox1 byte `xor` w0) `xor` w4) `xor` w8)) Zero + !b1 = fmap mapper range + where mapper byte = mdsColumnMult ((sbox0 . fromIntegral) ((sbox0 . fromIntegral) ((sbox1 . fromIntegral $ sbox1 byte `xor` w1) `xor` w5) `xor` w9)) One + !b2 = fmap mapper range + where mapper byte = mdsColumnMult ((sbox1 . fromIntegral) ((sbox1 . fromIntegral) ((sbox0 . fromIntegral $ sbox0 byte `xor` w2) `xor` w6) `xor` w10)) Two + !b3 = fmap mapper range + where mapper byte = mdsColumnMult ((sbox0 . fromIntegral) ((sbox1 . fromIntegral) ((sbox1 . fromIntegral $ sbox0 byte `xor` w3) `xor` w7) `xor` w11)) Three + + sboxBySize Bytes32 = (b0, b1, b2, b3) + where !b0 = fmap mapper range + where mapper byte = mdsColumnMult ((sbox1 . fromIntegral) ((sbox0 . fromIntegral) ((sbox0 . fromIntegral) ((sbox1 . fromIntegral $ sbox1 byte `xor` w0) `xor` w4) `xor` w8) `xor` w12)) Zero + !b1 = fmap mapper range + where mapper byte = mdsColumnMult ((sbox0 . fromIntegral) ((sbox0 . fromIntegral) ((sbox1 . fromIntegral) ((sbox1 . fromIntegral $ sbox0 byte `xor` w1) `xor` w5) `xor` w9) `xor` w13)) One + !b2 = fmap mapper range + where mapper byte = mdsColumnMult ((sbox1 . fromIntegral) ((sbox1 . fromIntegral) ((sbox0 . fromIntegral) ((sbox0 . fromIntegral $ sbox0 byte `xor` w2) `xor` w6) `xor` w10) `xor` w14)) Two + !b3 = fmap mapper range + where mapper byte = mdsColumnMult ((sbox0 . fromIntegral) ((sbox1 . fromIntegral) ((sbox1 . fromIntegral) ((sbox0 . fromIntegral $ sbox1 byte `xor` w3) `xor` w7) `xor` w11) `xor` w15)) Three + +genK :: (ByteArray ba) => KeyPackage ba -> [Word32] +genK keyPackage = concatMap makeTuple [0..19] + where makeTuple :: Word8 -> [Word32] + makeTuple idx = [a + b', rotateL (2 * b' + a) 9] + where tmp1 = replicate 4 $ 2 * idx + tmp2 = fmap (+1) tmp1 + a = h tmp1 keyPackage 0 + b = h tmp2 keyPackage 1 + b' = rotateL b 8 + +h :: (ByteArray ba) => [Word8] -> KeyPackage ba -> Int -> Word32 +h input keyPackage offset = foldl' xorMdsColMult 0 $ zip [y0f, y1f, y2f, y3f] $ enumFrom Zero + where key = rawKeyBytes keyPackage + [y0, y1, y2, y3] = take 4 input + (!y0f, !y1f, !y2f, !y3f) = run (y0, y1, y2, y3) $ byteSize keyPackage + + run :: (Word8, Word8, Word8, Word8) -> ByteSize -> (Word8, Word8, Word8, Word8) + run (!y0'', !y1'', !y2'', !y3'') Bytes32 = run (y0', y1', y2', y3') Bytes24 + where y0' = sbox1 (fromIntegral y0'') `xor` B.index key (4 * (6 + offset) + 0) + y1' = sbox0 (fromIntegral y1'') `xor` B.index key (4 * (6 + offset) + 1) + y2' = sbox0 (fromIntegral y2'') `xor` B.index key (4 * (6 + offset) + 2) + y3' = sbox1 (fromIntegral y3'') `xor` B.index key (4 * (6 + offset) + 3) + + run (!y0'', !y1'', !y2'', !y3'') Bytes24 = run (y0', y1', y2', y3') Bytes16 + where y0' = sbox1 (fromIntegral y0'') `xor` B.index key (4 * (4 + offset) + 0) + y1' = sbox1 (fromIntegral y1'') `xor` B.index key (4 * (4 + offset) + 1) + y2' = sbox0 (fromIntegral y2'') `xor` B.index key (4 * (4 + offset) + 2) + y3' = sbox0 (fromIntegral y3'') `xor` B.index key (4 * (4 + offset) + 3) + + run (!y0'', !y1'', !y2'', !y3'') Bytes16 = (y0', y1', y2', y3') + where y0' = sbox1 . fromIntegral $ (sbox0 . fromIntegral $ (sbox0 (fromIntegral y0'') `xor` B.index key (4 * (2 + offset) + 0))) `xor` B.index key (4 * (0 + offset) + 0) + y1' = sbox0 . fromIntegral $ (sbox0 . fromIntegral $ (sbox1 (fromIntegral y1'') `xor` B.index key (4 * (2 + offset) + 1))) `xor` B.index key (4 * (0 + offset) + 1) + y2' = sbox1 . fromIntegral $ (sbox1 . fromIntegral $ (sbox0 (fromIntegral y2'') `xor` B.index key (4 * (2 + offset) + 2))) `xor` B.index key (4 * (0 + offset) + 2) + y3' = sbox0 . fromIntegral $ (sbox1 . fromIntegral $ (sbox1 (fromIntegral y3'') `xor` B.index key (4 * (2 + offset) + 3))) `xor` B.index key (4 * (0 + offset) + 3) + + xorMdsColMult :: Word32 -> (Word8, Column) -> Word32 + xorMdsColMult acc wordAndIndex = acc `xor` uncurry mdsColumnMult wordAndIndex + +mdsColumnMult :: Word8 -> Column -> Word32 +mdsColumnMult !byte !col = + case col of Zero -> input .|. rotateL mul5B 8 .|. rotateL mulEF 16 .|. rotateL mulEF 24 + One -> mulEF .|. rotateL mulEF 8 .|. rotateL mul5B 16 .|. rotateL input 24 + Two -> mul5B .|. rotateL mulEF 8 .|. rotateL input 16 .|. rotateL mulEF 24 + Three -> mul5B .|. rotateL input 8 .|. rotateL mulEF 16 .|. rotateL mul5B 24 + where input = fromIntegral byte + mul5B = fromIntegral $ gfMult mdsPolynomial byte 0x5B + mulEF = fromIntegral $ gfMult mdsPolynomial byte 0xEF + +tupInd :: (Bits b) => b -> (a, a) -> a +tupInd b + | testBit b 0 = snd + | otherwise = fst + +gfMult :: Word32 -> Word8 -> Word8 -> Word8 +gfMult p a b = fromIntegral $ run a b' p' result 0 + where b' = (0, fromIntegral b) + p' = (0, p) + result = 0 + + run :: Word8 -> (Word32, Word32) -> (Word32, Word32) -> Word32 -> Int -> Word32 + run a' b'' p'' result' count = + if count == 7 + then result'' + else run a'' b''' p'' result'' (count + 1) + where result'' = result' `xor` tupInd (a' .&. 1) b'' + a'' = shiftR a' 1 + b''' = (fst b'', tupInd (shiftR (snd b'') 7) p'' `xor` shiftL (snd b'') 1) diff --git a/bundled/Crypto/Cipher/Types.hs b/bundled/Crypto/Cipher/Types.hs new file mode 100644 index 0000000..ab5dd37 --- /dev/null +++ b/bundled/Crypto/Cipher/Types.hs @@ -0,0 +1,39 @@ +-- | +-- Module : Crypto.Cipher.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : Stable +-- Portability : Excellent +-- +-- Symmetric cipher basic types +-- +{-# LANGUAGE DeriveDataTypeable #-} +module Crypto.Cipher.Types + ( + -- * Cipher classes + Cipher(..) + , BlockCipher(..) + , BlockCipher128(..) + , StreamCipher(..) + , DataUnitOffset + , KeySizeSpecifier(..) + -- , cfb8Encrypt + -- , cfb8Decrypt + -- * AEAD functions + , AEADMode(..) + , CCM_M(..) + , CCM_L(..) + , module Crypto.Cipher.Types.AEAD + -- * Initial Vector type and constructor + , IV + , makeIV + , nullIV + , ivAdd + -- * Authentification Tag + , AuthTag(..) + ) where + +import Crypto.Cipher.Types.Base +import Crypto.Cipher.Types.Block +import Crypto.Cipher.Types.Stream +import Crypto.Cipher.Types.AEAD diff --git a/bundled/Crypto/Cipher/Types/AEAD.hs b/bundled/Crypto/Cipher/Types/AEAD.hs new file mode 100644 index 0000000..23c1a25 --- /dev/null +++ b/bundled/Crypto/Cipher/Types/AEAD.hs @@ -0,0 +1,74 @@ +-- | +-- Module : Crypto.Cipher.Types.AEAD +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : Stable +-- Portability : Excellent +-- +-- AEAD cipher basic types +-- +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +module Crypto.Cipher.Types.AEAD where + +import Crypto.Cipher.Types.Base +import Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray) +import qualified Crypto.Internal.ByteArray as B +import Crypto.Internal.Imports + +-- | AEAD Implementation +data AEADModeImpl st = AEADModeImpl + { aeadImplAppendHeader :: forall ba . ByteArrayAccess ba => st -> ba -> st + , aeadImplEncrypt :: forall ba . ByteArray ba => st -> ba -> (ba, st) + , aeadImplDecrypt :: forall ba . ByteArray ba => st -> ba -> (ba, st) + , aeadImplFinalize :: st -> Int -> AuthTag + } + +-- | Authenticated Encryption with Associated Data algorithms +data AEAD cipher = forall st . AEAD + { aeadModeImpl :: AEADModeImpl st + , aeadState :: !st + } + +-- | Append some header information to an AEAD context +aeadAppendHeader :: ByteArrayAccess aad => AEAD cipher -> aad -> AEAD cipher +aeadAppendHeader (AEAD impl st) aad = AEAD impl $ aeadImplAppendHeader impl st aad + +-- | Encrypt some data and update the AEAD context +aeadEncrypt :: ByteArray ba => AEAD cipher -> ba -> (ba, AEAD cipher) +aeadEncrypt (AEAD impl st) ba = second (AEAD impl) $ aeadImplEncrypt impl st ba + +-- | Decrypt some data and update the AEAD context +aeadDecrypt :: ByteArray ba => AEAD cipher -> ba -> (ba, AEAD cipher) +aeadDecrypt (AEAD impl st) ba = second (AEAD impl) $ aeadImplDecrypt impl st ba + +-- | Finalize the AEAD context and return the authentication tag +aeadFinalize :: AEAD cipher -> Int -> AuthTag +aeadFinalize (AEAD impl st) = aeadImplFinalize impl st + +-- | Simple AEAD encryption +aeadSimpleEncrypt :: (ByteArrayAccess aad, ByteArray ba) + => AEAD a -- ^ A new AEAD Context + -> aad -- ^ Optional Authentication data header + -> ba -- ^ Optional Plaintext + -> Int -- ^ Tag length + -> (AuthTag, ba) -- ^ Authentication tag and ciphertext +aeadSimpleEncrypt aeadIni header input taglen = (tag, output) + where aead = aeadAppendHeader aeadIni header + (output, aeadFinal) = aeadEncrypt aead input + tag = aeadFinalize aeadFinal taglen + +-- | Simple AEAD decryption +aeadSimpleDecrypt :: (ByteArrayAccess aad, ByteArray ba) + => AEAD a -- ^ A new AEAD Context + -> aad -- ^ Optional Authentication data header + -> ba -- ^ Ciphertext + -> AuthTag -- ^ The authentication tag + -> Maybe ba -- ^ Plaintext +aeadSimpleDecrypt aeadIni header input authTag + | tag == authTag = Just output + | otherwise = Nothing + where aead = aeadAppendHeader aeadIni header + (output, aeadFinal) = aeadDecrypt aead input + tag = aeadFinalize aeadFinal (B.length authTag) + diff --git a/bundled/Crypto/Cipher/Types/Base.hs b/bundled/Crypto/Cipher/Types/Base.hs new file mode 100644 index 0000000..37d9028 --- /dev/null +++ b/bundled/Crypto/Cipher/Types/Base.hs @@ -0,0 +1,65 @@ +-- | +-- Module : Crypto.Cipher.Types.Base +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : Stable +-- Portability : Excellent +-- +-- Symmetric cipher basic types +-- +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Crypto.Cipher.Types.Base + ( KeySizeSpecifier(..) + , Cipher(..) + , AuthTag(..) + , AEADMode(..) + , CCM_M(..) + , CCM_L(..) + , DataUnitOffset + ) where + +import Data.Word +import Crypto.Internal.ByteArray (Bytes, ByteArrayAccess, ByteArray) +import qualified Crypto.Internal.ByteArray as B +import Crypto.Internal.DeepSeq +import Crypto.Error + +-- | Different specifier for key size in bytes +data KeySizeSpecifier = + KeySizeRange Int Int -- ^ in the range [min,max] + | KeySizeEnum [Int] -- ^ one of the specified values + | KeySizeFixed Int -- ^ a specific size + deriving (Show,Eq) + +-- | Offset inside an XTS data unit, measured in block size. +type DataUnitOffset = Word32 + +-- | Authentication Tag for AE cipher mode +newtype AuthTag = AuthTag { unAuthTag :: Bytes } + deriving (Show, ByteArrayAccess, NFData) + +instance Eq AuthTag where + (AuthTag a) == (AuthTag b) = B.constEq a b + +data CCM_M = CCM_M4 | CCM_M6 | CCM_M8 | CCM_M10 | CCM_M12 | CCM_M14 | CCM_M16 deriving (Show, Eq) +data CCM_L = CCM_L2 | CCM_L3 | CCM_L4 deriving (Show, Eq) + +-- | AEAD Mode +data AEADMode = + AEAD_OCB -- OCB3 + | AEAD_CCM Int CCM_M CCM_L + | AEAD_EAX + | AEAD_CWC + | AEAD_GCM + deriving (Show,Eq) + +-- | Symmetric cipher class. +class Cipher cipher where + -- | Initialize a cipher context from a key + cipherInit :: ByteArray key => key -> CryptoFailable cipher + -- | Cipher name + cipherName :: cipher -> String + -- | return the size of the key required for this cipher. + -- Some cipher accept any size for key + cipherKeySize :: cipher -> KeySizeSpecifier diff --git a/bundled/Crypto/Cipher/Types/Block.hs b/bundled/Crypto/Cipher/Types/Block.hs new file mode 100644 index 0000000..a2ac2d2 --- /dev/null +++ b/bundled/Crypto/Cipher/Types/Block.hs @@ -0,0 +1,271 @@ +-- | +-- Module : Crypto.Cipher.Types.Block +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : Stable +-- Portability : Excellent +-- +-- Block cipher basic types +-- +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE Rank2Types #-} +module Crypto.Cipher.Types.Block + ( + -- * BlockCipher + BlockCipher(..) + , BlockCipher128(..) + -- * Initialization vector (IV) + , IV(..) + , makeIV + , nullIV + , ivAdd + -- * XTS + , XTS + -- * AEAD + , AEAD(..) + -- , AEADState(..) + , AEADModeImpl(..) + , aeadAppendHeader + , aeadEncrypt + , aeadDecrypt + , aeadFinalize + -- * CFB 8 bits + --, cfb8Encrypt + --, cfb8Decrypt + ) where + +import Data.Word +import Crypto.Error +import Crypto.Cipher.Types.Base +import Crypto.Cipher.Types.GF +import Crypto.Cipher.Types.AEAD +import Crypto.Cipher.Types.Utils + +import Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, withByteArray, Bytes) +import qualified Crypto.Internal.ByteArray as B + +import Foreign.Ptr +import Foreign.Storable + +-- | an IV parametrized by the cipher +data IV c = forall byteArray . ByteArray byteArray => IV byteArray + +instance BlockCipher c => ByteArrayAccess (IV c) where + withByteArray (IV z) f = withByteArray z f + length (IV z) = B.length z +instance Eq (IV c) where + (IV a) == (IV b) = B.eq a b + +-- | XTS callback +type XTS ba cipher = (cipher, cipher) + -> IV cipher -- ^ Usually represent the Data Unit (e.g. disk sector) + -> DataUnitOffset -- ^ Offset in the data unit in number of blocks + -> ba -- ^ Data + -> ba -- ^ Processed Data + +-- | Symmetric block cipher class +class Cipher cipher => BlockCipher cipher where + -- | Return the size of block required for this block cipher + blockSize :: cipher -> Int + + -- | Encrypt blocks + -- + -- the input string need to be multiple of the block size + ecbEncrypt :: ByteArray ba => cipher -> ba -> ba + + -- | Decrypt blocks + -- + -- the input string need to be multiple of the block size + ecbDecrypt :: ByteArray ba => cipher -> ba -> ba + + -- | encrypt using the CBC mode. + -- + -- input need to be a multiple of the blocksize + cbcEncrypt :: ByteArray ba => cipher -> IV cipher -> ba -> ba + cbcEncrypt = cbcEncryptGeneric + -- | decrypt using the CBC mode. + -- + -- input need to be a multiple of the blocksize + cbcDecrypt :: ByteArray ba => cipher -> IV cipher -> ba -> ba + cbcDecrypt = cbcDecryptGeneric + + -- | encrypt using the CFB mode. + -- + -- input need to be a multiple of the blocksize + cfbEncrypt :: ByteArray ba => cipher -> IV cipher -> ba -> ba + cfbEncrypt = cfbEncryptGeneric + -- | decrypt using the CFB mode. + -- + -- input need to be a multiple of the blocksize + cfbDecrypt :: ByteArray ba => cipher -> IV cipher -> ba -> ba + cfbDecrypt = cfbDecryptGeneric + + -- | combine using the CTR mode. + -- + -- CTR mode produce a stream of randomized data that is combined + -- (by XOR operation) with the input stream. + -- + -- encryption and decryption are the same operation. + -- + -- input can be of any size + ctrCombine :: ByteArray ba => cipher -> IV cipher -> ba -> ba + ctrCombine = ctrCombineGeneric + + -- | Initialize a new AEAD State + -- + -- When Nothing is returns, it means the mode is not handled. + aeadInit :: ByteArrayAccess iv => AEADMode -> cipher -> iv -> CryptoFailable (AEAD cipher) + aeadInit _ _ _ = CryptoFailed CryptoError_AEADModeNotSupported + +-- | class of block cipher with a 128 bits block size +class BlockCipher cipher => BlockCipher128 cipher where + -- | encrypt using the XTS mode. + -- + -- input need to be a multiple of the blocksize, and the cipher + -- need to process 128 bits block only + xtsEncrypt :: ByteArray ba + => (cipher, cipher) + -> IV cipher -- ^ Usually represent the Data Unit (e.g. disk sector) + -> DataUnitOffset -- ^ Offset in the data unit in number of blocks + -> ba -- ^ Plaintext + -> ba -- ^ Ciphertext + xtsEncrypt = xtsEncryptGeneric + + -- | decrypt using the XTS mode. + -- + -- input need to be a multiple of the blocksize, and the cipher + -- need to process 128 bits block only + xtsDecrypt :: ByteArray ba + => (cipher, cipher) + -> IV cipher -- ^ Usually represent the Data Unit (e.g. disk sector) + -> DataUnitOffset -- ^ Offset in the data unit in number of blocks + -> ba -- ^ Ciphertext + -> ba -- ^ Plaintext + xtsDecrypt = xtsDecryptGeneric + +-- | Create an IV for a specified block cipher +makeIV :: (ByteArrayAccess b, BlockCipher c) => b -> Maybe (IV c) +makeIV b = toIV undefined + where toIV :: BlockCipher c => c -> Maybe (IV c) + toIV cipher + | B.length b == sz = Just $ IV (B.convert b :: Bytes) + | otherwise = Nothing + where sz = blockSize cipher + +-- | Create an IV that is effectively representing the number 0 +nullIV :: BlockCipher c => IV c +nullIV = toIV undefined + where toIV :: BlockCipher c => c -> IV c + toIV cipher = IV (B.zero (blockSize cipher) :: Bytes) + +-- | Increment an IV by a number. +-- +-- Assume the IV is in Big Endian format. +ivAdd :: IV c -> Int -> IV c +ivAdd (IV b) i = IV $ copy b + where copy :: ByteArray bs => bs -> bs + copy bs = B.copyAndFreeze bs $ loop i (B.length bs - 1) + + loop :: Int -> Int -> Ptr Word8 -> IO () + loop acc ofs p + | ofs < 0 = return () + | otherwise = do + v <- peek (p `plusPtr` ofs) :: IO Word8 + let accv = acc + fromIntegral v + (hi,lo) = accv `divMod` 256 + poke (p `plusPtr` ofs) (fromIntegral lo :: Word8) + loop hi (ofs - 1) p + +cbcEncryptGeneric :: (ByteArray ba, BlockCipher cipher) => cipher -> IV cipher -> ba -> ba +cbcEncryptGeneric cipher ivini input = mconcat $ doEnc ivini $ chunk (blockSize cipher) input + where doEnc _ [] = [] + doEnc iv (i:is) = + let o = ecbEncrypt cipher $ B.xor iv i + in o : doEnc (IV o) is + +cbcDecryptGeneric :: (ByteArray ba, BlockCipher cipher) => cipher -> IV cipher -> ba -> ba +cbcDecryptGeneric cipher ivini input = mconcat $ doDec ivini $ chunk (blockSize cipher) input + where + doDec _ [] = [] + doDec iv (i:is) = + let o = B.xor iv $ ecbDecrypt cipher i + in o : doDec (IV i) is + +cfbEncryptGeneric :: (ByteArray ba, BlockCipher cipher) => cipher -> IV cipher -> ba -> ba +cfbEncryptGeneric cipher ivini input = mconcat $ doEnc ivini $ chunk (blockSize cipher) input + where + doEnc _ [] = [] + doEnc (IV iv) (i:is) = + let o = B.xor i $ ecbEncrypt cipher iv + in o : doEnc (IV o) is + +cfbDecryptGeneric :: (ByteArray ba, BlockCipher cipher) => cipher -> IV cipher -> ba -> ba +cfbDecryptGeneric cipher ivini input = mconcat $ doDec ivini $ chunk (blockSize cipher) input + where + doDec _ [] = [] + doDec (IV iv) (i:is) = + let o = B.xor i $ ecbEncrypt cipher iv + in o : doDec (IV i) is + +ctrCombineGeneric :: (ByteArray ba, BlockCipher cipher) => cipher -> IV cipher -> ba -> ba +ctrCombineGeneric cipher ivini input = mconcat $ doCnt ivini $ chunk (blockSize cipher) input + where doCnt _ [] = [] + doCnt iv@(IV ivd) (i:is) = + let ivEnc = ecbEncrypt cipher ivd + in B.xor i ivEnc : doCnt (ivAdd iv 1) is + +xtsEncryptGeneric :: (ByteArray ba, BlockCipher128 cipher) => XTS ba cipher +xtsEncryptGeneric = xtsGeneric ecbEncrypt + +xtsDecryptGeneric :: (ByteArray ba, BlockCipher128 cipher) => XTS ba cipher +xtsDecryptGeneric = xtsGeneric ecbDecrypt + +xtsGeneric :: (ByteArray ba, BlockCipher128 cipher) + => (cipher -> ba -> ba) + -> (cipher, cipher) + -> IV cipher + -> DataUnitOffset + -> ba + -> ba +xtsGeneric f (cipher, tweakCipher) (IV iv) sPoint input = + mconcat $ doXts iniTweak $ chunk (blockSize cipher) input + where encTweak = ecbEncrypt tweakCipher iv + iniTweak = iterate xtsGFMul encTweak !! fromIntegral sPoint + doXts _ [] = [] + doXts tweak (i:is) = + let o = B.xor (f cipher $ B.xor i tweak) tweak + in o : doXts (xtsGFMul tweak) is + +{- +-- | Encrypt using CFB mode in 8 bit output +-- +-- Effectively turn a Block cipher in CFB mode into a Stream cipher +cfb8Encrypt :: BlockCipher a => a -> IV a -> B.byteString -> B.byteString +cfb8Encrypt ctx origIv msg = B.unsafeCreate (B.length msg) $ \dst -> loop dst origIv msg + where loop d iv@(IV i) m + | B.null m = return () + | otherwise = poke d out >> loop (d `plusPtr` 1) ni (B.drop 1 m) + where m' = if B.length m < blockSize ctx + then m `B.append` B.replicate (blockSize ctx - B.length m) 0 + else B.take (blockSize ctx) m + r = cfbEncrypt ctx iv m' + out = B.head r + ni = IV (B.drop 1 i `B.snoc` out) + +-- | Decrypt using CFB mode in 8 bit output +-- +-- Effectively turn a Block cipher in CFB mode into a Stream cipher +cfb8Decrypt :: BlockCipher a => a -> IV a -> B.byteString -> B.byteString +cfb8Decrypt ctx origIv msg = B.unsafeCreate (B.length msg) $ \dst -> loop dst origIv msg + where loop d iv@(IV i) m + | B.null m = return () + | otherwise = poke d out >> loop (d `plusPtr` 1) ni (B.drop 1 m) + where m' = if B.length m < blockSize ctx + then m `B.append` B.replicate (blockSize ctx - B.length m) 0 + else B.take (blockSize ctx) m + r = cfbDecrypt ctx iv m' + out = B.head r + ni = IV (B.drop 1 i `B.snoc` B.head m') +-} diff --git a/bundled/Crypto/Cipher/Types/GF.hs b/bundled/Crypto/Cipher/Types/GF.hs new file mode 100644 index 0000000..4172a24 --- /dev/null +++ b/bundled/Crypto/Cipher/Types/GF.hs @@ -0,0 +1,50 @@ +-- | +-- Module : Crypto.Cipher.Types.GF +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : Stable +-- Portability : Excellent +-- +-- Slow Galois Field arithmetic for generic XTS and GCM implementation +-- +module Crypto.Cipher.Types.GF + ( + -- * XTS support + xtsGFMul + ) where + +import Crypto.Internal.Imports +import Crypto.Internal.ByteArray (ByteArray, withByteArray) +import qualified Crypto.Internal.ByteArray as B +import Foreign.Storable +import Foreign.Ptr +import Data.Bits + +-- | Compute the gfmul with the XTS polynomial +-- +-- block size need to be 128 bits. +-- +-- FIXME: add support for big endian. +xtsGFMul :: ByteArray ba => ba -> ba +xtsGFMul b + | len == 16 = + B.allocAndFreeze len $ \dst -> + withByteArray b $ \src -> do + (hi,lo) <- gf <$> peek (castPtr src) <*> peek (castPtr src `plusPtr` 8) + poke (castPtr dst) lo + poke (castPtr dst `plusPtr` 8) hi + | otherwise = error "unsupported block size in GF" + where gf :: Word64 -> Word64 -> (Word64, Word64) + gf srcLo srcHi = + ((if carryLo then (.|. 1) else id) (srcHi `shiftL` 1) + ,(if carryHi then xor 0x87 else id) $ (srcLo `shiftL` 1) + ) + where carryHi = srcHi `testBit` 63 + carryLo = srcLo `testBit` 63 + len = B.length b +{- + const uint64_t gf_mask = cpu_to_le64(0x8000000000000000ULL); + uint64_t r = ((a->q[1] & gf_mask) ? cpu_to_le64(0x87) : 0); + a->q[1] = cpu_to_le64((le64_to_cpu(a->q[1]) << 1) | (a->q[0] & gf_mask ? 1 : 0)); + a->q[0] = cpu_to_le64(le64_to_cpu(a->q[0]) << 1) ^ r; +-} diff --git a/bundled/Crypto/Cipher/Types/Stream.hs b/bundled/Crypto/Cipher/Types/Stream.hs new file mode 100644 index 0000000..caa9e2d --- /dev/null +++ b/bundled/Crypto/Cipher/Types/Stream.hs @@ -0,0 +1,20 @@ +-- | +-- Module : Crypto.Cipher.Types.Stream +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : Stable +-- Portability : Excellent +-- +-- Stream cipher basic types +-- +module Crypto.Cipher.Types.Stream + ( StreamCipher(..) + ) where + +import Crypto.Cipher.Types.Base +import Crypto.Internal.ByteArray (ByteArray) + +-- | Symmetric stream cipher class +class Cipher cipher => StreamCipher cipher where + -- | Combine using the stream cipher + streamCombine :: ByteArray ba => cipher -> ba -> (ba, cipher) diff --git a/bundled/Crypto/Cipher/Types/Utils.hs b/bundled/Crypto/Cipher/Types/Utils.hs new file mode 100644 index 0000000..1185404 --- /dev/null +++ b/bundled/Crypto/Cipher/Types/Utils.hs @@ -0,0 +1,21 @@ +-- | +-- Module : Crypto.Cipher.Types.Utils +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : Stable +-- Portability : Excellent +-- +-- Basic utility for cipher related stuff +-- +module Crypto.Cipher.Types.Utils where + +import Crypto.Internal.ByteArray (ByteArray) +import qualified Crypto.Internal.ByteArray as B + +-- | Chunk some input byte array into @sz byte list of byte array. +chunk :: ByteArray b => Int -> b -> [b] +chunk sz bs = split bs + where split b | B.length b <= sz = [b] + | otherwise = + let (b1, b2) = B.splitAt sz b + in b1 : split b2 diff --git a/bundled/Crypto/Cipher/Utils.hs b/bundled/Crypto/Cipher/Utils.hs new file mode 100644 index 0000000..24e2e0a --- /dev/null +++ b/bundled/Crypto/Cipher/Utils.hs @@ -0,0 +1,18 @@ +module Crypto.Cipher.Utils + ( validateKeySize + ) where + +import Crypto.Error +import Crypto.Cipher.Types + +import Data.ByteArray as BA + +validateKeySize :: (ByteArrayAccess key, Cipher cipher) => cipher -> key -> CryptoFailable key +validateKeySize c k = if validKeyLength + then CryptoPassed k + else CryptoFailed CryptoError_KeySizeInvalid + where keyLength = BA.length k + validKeyLength = case cipherKeySize c of + KeySizeRange low high -> keyLength >= low && keyLength <= high + KeySizeEnum lengths -> keyLength `elem` lengths + KeySizeFixed s -> keyLength == s \ No newline at end of file diff --git a/bundled/Crypto/Cipher/XSalsa.hs b/bundled/Crypto/Cipher/XSalsa.hs new file mode 100644 index 0000000..0353aa2 --- /dev/null +++ b/bundled/Crypto/Cipher/XSalsa.hs @@ -0,0 +1,75 @@ +-- | +-- Module : Crypto.Cipher.XSalsa +-- License : BSD-style +-- Maintainer : Brandon Hamilton +-- Stability : stable +-- Portability : good +-- +-- Implementation of XSalsa20 algorithm +-- +-- Based on the Salsa20 algorithm with 256 bit key extended with 192 bit nonce + +{-# LANGUAGE ForeignFunctionInterface #-} +module Crypto.Cipher.XSalsa + ( initialize + , derive + , combine + , generate + , State + ) where + +import Crypto.Internal.ByteArray (ByteArrayAccess) +import qualified Crypto.Internal.ByteArray as B +import Crypto.Internal.Compat +import Crypto.Internal.Imports +import Foreign.Ptr +import Crypto.Cipher.Salsa hiding (initialize) + +-- | Initialize a new XSalsa context with the number of rounds, +-- the key and the nonce associated. +initialize :: (ByteArrayAccess key, ByteArrayAccess nonce) + => Int -- ^ number of rounds (8,12,20) + -> key -- ^ the key (256 bits) + -> nonce -- ^ the nonce (192 bits) + -> State -- ^ the initial XSalsa state +initialize nbRounds key nonce + | kLen /= 32 = error "XSalsa: key length should be 256 bits" + | nonceLen /= 24 = error "XSalsa: nonce length should be 192 bits" + | nbRounds `notElem` [8,12,20] = error "XSalsa: rounds should be 8, 12 or 20" + | otherwise = unsafeDoIO $ do + stPtr <- B.alloc 132 $ \stPtr -> + B.withByteArray nonce $ \noncePtr -> + B.withByteArray key $ \keyPtr -> + ccryptonite_xsalsa_init stPtr nbRounds kLen keyPtr nonceLen noncePtr + return $ State stPtr + where kLen = B.length key + nonceLen = B.length nonce + +-- | Use an already initialized context and new nonce material to derive another +-- XSalsa context. +-- +-- This allows a multi-level cascade where a first key @k1@ and nonce @n1@ is +-- used to get @HState(k1,n1)@, and this value is then used as key @k2@ to build +-- @XSalsa(k2,n2)@. Function 'initialize' is to be called with the first 192 +-- bits of @n1|n2@, and the call to @derive@ should add the remaining 128 bits. +-- +-- The output context always uses the same number of rounds as the input +-- context. +derive :: ByteArrayAccess nonce + => State -- ^ base XSalsa state + -> nonce -- ^ the remainder nonce (128 bits) + -> State -- ^ the new XSalsa state +derive (State stPtr') nonce + | nonceLen /= 16 = error "XSalsa: nonce length should be 128 bits" + | otherwise = unsafeDoIO $ do + stPtr <- B.copy stPtr' $ \stPtr -> + B.withByteArray nonce $ \noncePtr -> + ccryptonite_xsalsa_derive stPtr nonceLen noncePtr + return $ State stPtr + where nonceLen = B.length nonce + +foreign import ccall "cryptonite_xsalsa_init" + ccryptonite_xsalsa_init :: Ptr State -> Int -> Int -> Ptr Word8 -> Int -> Ptr Word8 -> IO () + +foreign import ccall "cryptonite_xsalsa_derive" + ccryptonite_xsalsa_derive :: Ptr State -> Int -> Ptr Word8 -> IO () diff --git a/bundled/Crypto/Error.hs b/bundled/Crypto/Error.hs new file mode 100644 index 0000000..4657ec0 --- /dev/null +++ b/bundled/Crypto/Error.hs @@ -0,0 +1,12 @@ +-- | +-- Module : Crypto.Error +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : Stable +-- Portability : Excellent +-- +module Crypto.Error + ( module Crypto.Error.Types + ) where + +import Crypto.Error.Types diff --git a/bundled/Crypto/Error/Types.hs b/bundled/Crypto/Error/Types.hs new file mode 100644 index 0000000..b72efad --- /dev/null +++ b/bundled/Crypto/Error/Types.hs @@ -0,0 +1,119 @@ +-- | +-- Module : Crypto.Error.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +-- Cryptographic Error enumeration and handling +-- +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +module Crypto.Error.Types + ( CryptoError(..) + , CryptoFailable(..) + , throwCryptoErrorIO + , throwCryptoError + , onCryptoFailure + , eitherCryptoError + , maybeCryptoError + ) where + +import qualified Control.Exception as E +import Data.Data + +import Basement.Monad (MonadFailure(..)) + +-- | Enumeration of all possible errors that can be found in this library +data CryptoError = + -- symmetric cipher errors + CryptoError_KeySizeInvalid + | CryptoError_IvSizeInvalid + | CryptoError_SeedSizeInvalid + | CryptoError_AEADModeNotSupported + -- public key cryptography error + | CryptoError_SecretKeySizeInvalid + | CryptoError_SecretKeyStructureInvalid + | CryptoError_PublicKeySizeInvalid + | CryptoError_SharedSecretSizeInvalid + -- elliptic cryptography error + | CryptoError_EcScalarOutOfBounds + | CryptoError_PointSizeInvalid + | CryptoError_PointFormatInvalid + | CryptoError_PointFormatUnsupported + | CryptoError_PointCoordinatesInvalid + | CryptoError_ScalarMultiplicationInvalid + -- Message authentification error + | CryptoError_MacKeyInvalid + | CryptoError_AuthenticationTagSizeInvalid + -- Prime generation error + | CryptoError_PrimeSizeInvalid + -- Parameter errors + | CryptoError_SaltTooSmall + | CryptoError_OutputLengthTooSmall + | CryptoError_OutputLengthTooBig + deriving (Show,Eq,Enum,Data) + +instance E.Exception CryptoError + +-- | A simple Either like type to represent a computation that can fail +-- +-- 2 possibles values are: +-- +-- * 'CryptoPassed' : The computation succeeded, and contains the result of the computation +-- +-- * 'CryptoFailed' : The computation failed, and contains the cryptographic error associated +-- +data CryptoFailable a = + CryptoPassed a + | CryptoFailed CryptoError + deriving (Show) + +instance Eq a => Eq (CryptoFailable a) where + (==) (CryptoPassed a) (CryptoPassed b) = a == b + (==) (CryptoFailed e1) (CryptoFailed e2) = e1 == e2 + (==) _ _ = False + +instance Functor CryptoFailable where + fmap f (CryptoPassed a) = CryptoPassed (f a) + fmap _ (CryptoFailed r) = CryptoFailed r + +instance Applicative CryptoFailable where + pure a = CryptoPassed a + (<*>) fm m = fm >>= \p -> m >>= \r2 -> return (p r2) +instance Monad CryptoFailable where + return = pure + (>>=) m1 m2 = do + case m1 of + CryptoPassed a -> m2 a + CryptoFailed e -> CryptoFailed e + +instance MonadFailure CryptoFailable where + type Failure CryptoFailable = CryptoError + mFail = CryptoFailed + +-- | Throw an CryptoError as exception on CryptoFailed result, +-- otherwise return the computed value +throwCryptoErrorIO :: CryptoFailable a -> IO a +throwCryptoErrorIO (CryptoFailed e) = E.throwIO e +throwCryptoErrorIO (CryptoPassed r) = return r + +-- | Same as 'throwCryptoErrorIO' but throw the error asynchronously. +throwCryptoError :: CryptoFailable a -> a +throwCryptoError (CryptoFailed e) = E.throw e +throwCryptoError (CryptoPassed r) = r + +-- | Simple 'either' like combinator for CryptoFailable type +onCryptoFailure :: (CryptoError -> r) -> (a -> r) -> CryptoFailable a -> r +onCryptoFailure onError _ (CryptoFailed e) = onError e +onCryptoFailure _ onSuccess (CryptoPassed r) = onSuccess r + +-- | Transform a CryptoFailable to an Either +eitherCryptoError :: CryptoFailable a -> Either CryptoError a +eitherCryptoError (CryptoFailed e) = Left e +eitherCryptoError (CryptoPassed a) = Right a + +-- | Transform a CryptoFailable to a Maybe +maybeCryptoError :: CryptoFailable a -> Maybe a +maybeCryptoError (CryptoFailed _) = Nothing +maybeCryptoError (CryptoPassed r) = Just r diff --git a/bundled/Crypto/Internal/Builder.hs b/bundled/Crypto/Internal/Builder.hs new file mode 100644 index 0000000..bc072e3 --- /dev/null +++ b/bundled/Crypto/Internal/Builder.hs @@ -0,0 +1,53 @@ +-- | +-- Module : Crypto.Internal.Builder +-- License : BSD-style +-- Maintainer : Olivier Chéron +-- Stability : stable +-- Portability : Good +-- +-- Delaying and merging ByteArray allocations. This is similar to module +-- "Data.ByteArray.Pack" except the total length is computed automatically based +-- on what is appended. +-- +{-# LANGUAGE BangPatterns #-} +module Crypto.Internal.Builder + ( Builder + , buildAndFreeze + , builderLength + , byte + , bytes + , zero + ) where + +import Data.ByteArray (ByteArray, ByteArrayAccess) +import qualified Data.ByteArray as B +import Data.Memory.PtrMethods (memSet) + +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (poke) + +import Crypto.Internal.Imports hiding (empty) + +data Builder = Builder !Int (Ptr Word8 -> IO ()) -- size and initializer + +instance Semigroup Builder where + (Builder s1 f1) <> (Builder s2 f2) = Builder (s1 + s2) f + where f p = f1 p >> f2 (p `plusPtr` s1) + +builderLength :: Builder -> Int +builderLength (Builder s _) = s + +buildAndFreeze :: ByteArray ba => Builder -> ba +buildAndFreeze (Builder s f) = B.allocAndFreeze s f + +byte :: Word8 -> Builder +byte !b = Builder 1 (`poke` b) + +bytes :: ByteArrayAccess ba => ba -> Builder +bytes bs = Builder (B.length bs) (B.copyByteArrayToPtr bs) + +zero :: Int -> Builder +zero s = if s > 0 then Builder s (\p -> memSet p 0 s) else empty + +empty :: Builder +empty = Builder 0 (const $ return ()) diff --git a/bundled/Crypto/Internal/ByteArray.hs b/bundled/Crypto/Internal/ByteArray.hs new file mode 100644 index 0000000..57ab57a --- /dev/null +++ b/bundled/Crypto/Internal/ByteArray.hs @@ -0,0 +1,39 @@ +-- | +-- Module : Crypto.Internal.ByteArray +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +-- Simple and efficient byte array types +-- +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_HADDOCK hide #-} +module Crypto.Internal.ByteArray + ( module Data.ByteArray + , module Data.ByteArray.Mapping + , module Data.ByteArray.Encoding + , constAllZero + ) where + +import Data.ByteArray +import Data.ByteArray.Mapping +import Data.ByteArray.Encoding + +import Data.Bits ((.|.)) +import Data.Word (Word8) +import Foreign.Ptr (Ptr) +import Foreign.Storable (peekByteOff) + +import Crypto.Internal.Compat (unsafeDoIO) + +constAllZero :: ByteArrayAccess ba => ba -> Bool +constAllZero b = unsafeDoIO $ withByteArray b $ \p -> loop p 0 0 + where + loop :: Ptr b -> Int -> Word8 -> IO Bool + loop p i !acc + | i == len = return $! acc == 0 + | otherwise = do + e <- peekByteOff p i + loop p (i+1) (acc .|. e) + len = Data.ByteArray.length b diff --git a/bundled/Crypto/Internal/Compat.hs b/bundled/Crypto/Internal/Compat.hs new file mode 100644 index 0000000..30615d9 --- /dev/null +++ b/bundled/Crypto/Internal/Compat.hs @@ -0,0 +1,48 @@ +-- | +-- Module : Crypto.Internal.Compat +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +-- This module tries to keep all the difference between versions of base +-- or other needed packages, so that modules don't need to use CPP. +-- +{-# LANGUAGE CPP #-} +module Crypto.Internal.Compat + ( unsafeDoIO + , popCount + , byteSwap64 + ) where + +import System.IO.Unsafe +import Data.Word +import Data.Bits + +-- | Perform io for hashes that do allocation and FFI. +-- 'unsafeDupablePerformIO' is used when possible as the +-- computation is pure and the output is directly linked +-- to the input. We also do not modify anything after it has +-- been returned to the user. +unsafeDoIO :: IO a -> a +#if __GLASGOW_HASKELL__ > 704 +unsafeDoIO = unsafeDupablePerformIO +#else +unsafeDoIO = unsafePerformIO +#endif + +#if !(MIN_VERSION_base(4,5,0)) +popCount :: Word64 -> Int +popCount n = loop 0 n + where loop c 0 = c + loop c i = loop (c + if testBit c 0 then 1 else 0) (i `shiftR` 1) +#endif + +#if !(MIN_VERSION_base(4,7,0)) +byteSwap64 :: Word64 -> Word64 +byteSwap64 w = + (w `shiftR` 56) .|. (w `shiftL` 56) + .|. ((w `shiftR` 40) .&. 0xff00) .|. ((w .&. 0xff00) `shiftL` 40) + .|. ((w `shiftR` 24) .&. 0xff0000) .|. ((w .&. 0xff0000) `shiftL` 24) + .|. ((w `shiftR` 8) .&. 0xff000000) .|. ((w .&. 0xff000000) `shiftL` 8) +#endif diff --git a/bundled/Crypto/Internal/CompatPrim.hs b/bundled/Crypto/Internal/CompatPrim.hs new file mode 100644 index 0000000..e223ec3 --- /dev/null +++ b/bundled/Crypto/Internal/CompatPrim.hs @@ -0,0 +1,109 @@ +-- | +-- Module : Crypto.Internal.CompatPrim +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Compat +-- +-- This module tries to keep all the difference between versions of ghc primitive +-- or other needed packages, so that modules don't need to use CPP. +-- +-- Note that MagicHash and CPP conflicts in places, making it "more interesting" +-- to write compat code for primitives. +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +module Crypto.Internal.CompatPrim + ( be32Prim + , le32Prim + , byteswap32Prim + , booleanPrim + , convert4To32 + ) where + +#if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN) +import Data.Memory.Endian (getSystemEndianness, Endianness(..)) +#endif + +#if __GLASGOW_HASKELL__ >= 902 +import GHC.Prim +#else +import GHC.Prim hiding (Word32#) +type Word32# = Word# +#endif + +-- | Byteswap Word# to or from Big Endian +-- +-- On a big endian machine, this function is a nop. +be32Prim :: Word32# -> Word32# +#ifdef ARCH_IS_LITTLE_ENDIAN +be32Prim = byteswap32Prim +#elif defined(ARCH_IS_BIG_ENDIAN) +be32Prim = id +#else +be32Prim w = if getSystemEndianness == LittleEndian then byteswap32Prim w else w +#endif + +-- | Byteswap Word# to or from Little Endian +-- +-- On a little endian machine, this function is a nop. +le32Prim :: Word32# -> Word32# +#ifdef ARCH_IS_LITTLE_ENDIAN +le32Prim w = w +#elif defined(ARCH_IS_BIG_ENDIAN) +le32Prim = byteswap32Prim +#else +le32Prim w = if getSystemEndianness == LittleEndian then w else byteswap32Prim w +#endif + +-- | Simple compatibility for byteswap the lower 32 bits of a Word# +-- at the primitive level +byteswap32Prim :: Word32# -> Word32# +#if __GLASGOW_HASKELL__ >= 902 +byteswap32Prim w = wordToWord32# (byteSwap32# (word32ToWord# w)) +#else +byteswap32Prim w = byteSwap32# w +#endif + +-- | Combine 4 word8 [a,b,c,d] to a word32 representing [a,b,c,d] +convert4To32 :: Word# -> Word# -> Word# -> Word# + -> Word# +convert4To32 a b c d = or# (or# c1 c2) (or# c3 c4) + where +#ifdef ARCH_IS_LITTLE_ENDIAN + !c1 = uncheckedShiftL# a 24# + !c2 = uncheckedShiftL# b 16# + !c3 = uncheckedShiftL# c 8# + !c4 = d +#elif defined(ARCH_IS_BIG_ENDIAN) + !c1 = uncheckedShiftL# d 24# + !c2 = uncheckedShiftL# c 16# + !c3 = uncheckedShiftL# b 8# + !c4 = a +#else + !c1 + | getSystemEndianness == LittleEndian = uncheckedShiftL# a 24# + | otherwise = uncheckedShiftL# d 24# + !c2 + | getSystemEndianness == LittleEndian = uncheckedShiftL# b 16# + | otherwise = uncheckedShiftL# c 16# + !c3 + | getSystemEndianness == LittleEndian = uncheckedShiftL# c 8# + | otherwise = uncheckedShiftL# b 8# + !c4 + | getSystemEndianness == LittleEndian = d + | otherwise = a +#endif + +-- | Simple wrapper to handle pre 7.8 and future, where +-- most comparaison functions don't returns a boolean +-- anymore. +#if __GLASGOW_HASKELL__ >= 708 +booleanPrim :: Int# -> Bool +booleanPrim v = tagToEnum# v +#else +booleanPrim :: Bool -> Bool +booleanPrim b = b +#endif diff --git a/bundled/Crypto/Internal/DeepSeq.hs b/bundled/Crypto/Internal/DeepSeq.hs new file mode 100644 index 0000000..86b7845 --- /dev/null +++ b/bundled/Crypto/Internal/DeepSeq.hs @@ -0,0 +1,35 @@ +-- | +-- Module : Crypto.Internal.DeepSeq +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Simple abstraction module to allow compilation without deepseq +-- by defining our own NFData class if not compiling with deepseq +-- support. +-- +{-# LANGUAGE CPP #-} +module Crypto.Internal.DeepSeq + ( NFData(..) + ) where + +#ifdef WITH_DEEPSEQ_SUPPORT +import Control.DeepSeq +#else +import Data.Word +import Data.ByteArray + +class NFData a where rnf :: a -> () + +instance NFData Word8 where rnf w = w `seq` () +instance NFData Word16 where rnf w = w `seq` () +instance NFData Word32 where rnf w = w `seq` () +instance NFData Word64 where rnf w = w `seq` () + +instance NFData Bytes where rnf b = b `seq` () +instance NFData ScrubbedBytes where rnf b = b `seq` () + +instance NFData Integer where rnf i = i `seq` () + +#endif diff --git a/bundled/Crypto/Internal/Imports.hs b/bundled/Crypto/Internal/Imports.hs new file mode 100644 index 0000000..6d551e9 --- /dev/null +++ b/bundled/Crypto/Internal/Imports.hs @@ -0,0 +1,20 @@ +-- | +-- Module : Crypto.Internal.Imports +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +{-# LANGUAGE CPP #-} +module Crypto.Internal.Imports + ( module X + ) where + +import Data.Word as X +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup as X (Semigroup(..)) +#endif +import Control.Applicative as X +import Control.Monad as X (forM, forM_, void) +import Control.Arrow as X (first, second) +import Crypto.Internal.DeepSeq as X diff --git a/bundled/Crypto/Internal/Nat.hs b/bundled/Crypto/Internal/Nat.hs new file mode 100644 index 0000000..03b75c0 --- /dev/null +++ b/bundled/Crypto/Internal/Nat.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Crypto.Internal.Nat + ( type IsDivisibleBy8 + , type IsAtMost, type IsAtLeast + , byteLen + , integralNatVal + , type IsDiv8 + , type Div8 + , type Mod8 + ) where + +import GHC.TypeLits + +byteLen :: (KnownNat bitlen, Num a) => proxy bitlen -> a +byteLen d = fromInteger ((natVal d + 7) `div` 8) + +integralNatVal :: (KnownNat bitlen, Num a) => proxy bitlen -> a +integralNatVal = fromInteger . natVal + +type family IsLE (bitlen :: Nat) (n :: Nat) (c :: Bool) where + IsLE _ _ 'True = 'True +#if MIN_VERSION_base(4,9,0) + IsLE bitlen n 'False = TypeError + ( ('Text "bitlen " ':<>: 'ShowType bitlen ':<>: 'Text " is greater than " ':<>: 'ShowType n) + ':$$: ('Text "You have tried to use an invalid Digest size. Please, refer to the documentation.") + ) +#else + IsLE bitlen n 'False = 'False +#endif + +-- | ensure the given `bitlen` is lesser or equal to `n` +-- +type IsAtMost (bitlen :: Nat) (n :: Nat) = IsLE bitlen n (bitlen <=? n) ~ 'True + +type family IsGE (bitlen :: Nat) (n :: Nat) (c :: Bool) where + IsGE _ _ 'True = 'True +#if MIN_VERSION_base(4,9,0) + IsGE bitlen n 'False = TypeError + ( ('Text "bitlen " ':<>: 'ShowType bitlen ':<>: 'Text " is lesser than " ':<>: 'ShowType n) + ':$$: ('Text "You have tried to use an invalid Digest size. Please, refer to the documentation.") + ) +#else + IsGE bitlen n 'False = 'False +#endif + +-- | ensure the given `bitlen` is greater or equal to `n` +-- +type IsAtLeast (bitlen :: Nat) (n :: Nat) = IsGE bitlen n (n <=? bitlen) ~ 'True + +type family Div8 (bitLen :: Nat) where + Div8 0 = 0 + Div8 1 = 0 + Div8 2 = 0 + Div8 3 = 0 + Div8 4 = 0 + Div8 5 = 0 + Div8 6 = 0 + Div8 7 = 0 + Div8 8 = 1 + Div8 9 = 1 + Div8 10 = 1 + Div8 11 = 1 + Div8 12 = 1 + Div8 13 = 1 + Div8 14 = 1 + Div8 15 = 1 + Div8 16 = 2 + Div8 17 = 2 + Div8 18 = 2 + Div8 19 = 2 + Div8 20 = 2 + Div8 21 = 2 + Div8 22 = 2 + Div8 23 = 2 + Div8 24 = 3 + Div8 25 = 3 + Div8 26 = 3 + Div8 27 = 3 + Div8 28 = 3 + Div8 29 = 3 + Div8 30 = 3 + Div8 31 = 3 + Div8 32 = 4 + Div8 33 = 4 + Div8 34 = 4 + Div8 35 = 4 + Div8 36 = 4 + Div8 37 = 4 + Div8 38 = 4 + Div8 39 = 4 + Div8 40 = 5 + Div8 41 = 5 + Div8 42 = 5 + Div8 43 = 5 + Div8 44 = 5 + Div8 45 = 5 + Div8 46 = 5 + Div8 47 = 5 + Div8 48 = 6 + Div8 49 = 6 + Div8 50 = 6 + Div8 51 = 6 + Div8 52 = 6 + Div8 53 = 6 + Div8 54 = 6 + Div8 55 = 6 + Div8 56 = 7 + Div8 57 = 7 + Div8 58 = 7 + Div8 59 = 7 + Div8 60 = 7 + Div8 61 = 7 + Div8 62 = 7 + Div8 63 = 7 + Div8 64 = 8 + Div8 n = 8 + Div8 (n - 64) + +type family IsDiv8 (bitLen :: Nat) (n :: Nat) where + IsDiv8 _ 0 = 'True +#if MIN_VERSION_base(4,9,0) + IsDiv8 bitLen 1 = TypeError ('Text "bitLen " ':<>: 'ShowType bitLen ':<>: 'Text " is not divisible by 8") + IsDiv8 bitLen 2 = TypeError ('Text "bitLen " ':<>: 'ShowType bitLen ':<>: 'Text " is not divisible by 8") + IsDiv8 bitLen 3 = TypeError ('Text "bitLen " ':<>: 'ShowType bitLen ':<>: 'Text " is not divisible by 8") + IsDiv8 bitLen 4 = TypeError ('Text "bitLen " ':<>: 'ShowType bitLen ':<>: 'Text " is not divisible by 8") + IsDiv8 bitLen 5 = TypeError ('Text "bitLen " ':<>: 'ShowType bitLen ':<>: 'Text " is not divisible by 8") + IsDiv8 bitLen 6 = TypeError ('Text "bitLen " ':<>: 'ShowType bitLen ':<>: 'Text " is not divisible by 8") + IsDiv8 bitLen 7 = TypeError ('Text "bitLen " ':<>: 'ShowType bitLen ':<>: 'Text " is not divisible by 8") +#else + IsDiv8 _ 1 = 'False + IsDiv8 _ 2 = 'False + IsDiv8 _ 3 = 'False + IsDiv8 _ 4 = 'False + IsDiv8 _ 5 = 'False + IsDiv8 _ 6 = 'False + IsDiv8 _ 7 = 'False +#endif + IsDiv8 _ n = IsDiv8 n (Mod8 n) + +type family Mod8 (n :: Nat) where + Mod8 0 = 0 + Mod8 1 = 1 + Mod8 2 = 2 + Mod8 3 = 3 + Mod8 4 = 4 + Mod8 5 = 5 + Mod8 6 = 6 + Mod8 7 = 7 + Mod8 8 = 0 + Mod8 9 = 1 + Mod8 10 = 2 + Mod8 11 = 3 + Mod8 12 = 4 + Mod8 13 = 5 + Mod8 14 = 6 + Mod8 15 = 7 + Mod8 16 = 0 + Mod8 17 = 1 + Mod8 18 = 2 + Mod8 19 = 3 + Mod8 20 = 4 + Mod8 21 = 5 + Mod8 22 = 6 + Mod8 23 = 7 + Mod8 24 = 0 + Mod8 25 = 1 + Mod8 26 = 2 + Mod8 27 = 3 + Mod8 28 = 4 + Mod8 29 = 5 + Mod8 30 = 6 + Mod8 31 = 7 + Mod8 32 = 0 + Mod8 33 = 1 + Mod8 34 = 2 + Mod8 35 = 3 + Mod8 36 = 4 + Mod8 37 = 5 + Mod8 38 = 6 + Mod8 39 = 7 + Mod8 40 = 0 + Mod8 41 = 1 + Mod8 42 = 2 + Mod8 43 = 3 + Mod8 44 = 4 + Mod8 45 = 5 + Mod8 46 = 6 + Mod8 47 = 7 + Mod8 48 = 0 + Mod8 49 = 1 + Mod8 50 = 2 + Mod8 51 = 3 + Mod8 52 = 4 + Mod8 53 = 5 + Mod8 54 = 6 + Mod8 55 = 7 + Mod8 56 = 0 + Mod8 57 = 1 + Mod8 58 = 2 + Mod8 59 = 3 + Mod8 60 = 4 + Mod8 61 = 5 + Mod8 62 = 6 + Mod8 63 = 7 + Mod8 n = Mod8 (n - 64) + +-- | ensure the given `bitlen` is divisible by 8 +-- +type IsDivisibleBy8 bitLen = IsDiv8 bitLen bitLen ~ 'True diff --git a/bundled/Crypto/Internal/WordArray.hs b/bundled/Crypto/Internal/WordArray.hs new file mode 100644 index 0000000..0f3c0f6 --- /dev/null +++ b/bundled/Crypto/Internal/WordArray.hs @@ -0,0 +1,157 @@ +-- | +-- Module : Crypto.Internal.WordArray +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +-- Small and self contained array representation +-- with limited safety for internal use. +-- +-- The array produced should never be exposed to the user directly. +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +module Crypto.Internal.WordArray + ( Array8 + , Array32 + , Array64 + , MutableArray32 + , array8 + , array32 + , array32FromAddrBE + , allocArray32AndFreeze + , mutableArray32 + , array64 + , arrayRead8 + , arrayRead32 + , arrayRead64 + , mutableArrayRead32 + , mutableArrayWrite32 + , mutableArrayWriteXor32 + , mutableArray32FromAddrBE + , mutableArray32Freeze + ) where + +import Data.Word +import Data.Bits (xor) +import Crypto.Internal.Compat +import Crypto.Internal.CompatPrim +import GHC.Prim +import GHC.Types +import GHC.Word + +-- | Array of Word8 +data Array8 = Array8 Addr# + +-- | Array of Word32 +data Array32 = Array32 ByteArray# + +-- | Array of Word64 +data Array64 = Array64 ByteArray# + +-- | Array of mutable Word32 +data MutableArray32 = MutableArray32 (MutableByteArray# RealWorld) + +-- | Create an array of Word8 aliasing an Addr# +array8 :: Addr# -> Array8 +array8 = Array8 + +-- | Create an Array of Word32 of specific size from a list of Word32 +array32 :: Int -> [Word32] -> Array32 +array32 n l = unsafeDoIO (mutableArray32 n l >>= mutableArray32Freeze) +{-# NOINLINE array32 #-} + +-- | Create an Array of BE Word32 aliasing an Addr +array32FromAddrBE :: Int -> Addr# -> Array32 +array32FromAddrBE n a = + unsafeDoIO (mutableArray32FromAddrBE n a >>= mutableArray32Freeze) +{-# NOINLINE array32FromAddrBE #-} + +-- | Create an Array of Word32 using an initializer +allocArray32AndFreeze :: Int -> (MutableArray32 -> IO ()) -> Array32 +allocArray32AndFreeze n f = + unsafeDoIO (mutableArray32 n [] >>= \m -> f m >> mutableArray32Freeze m) +{-# NOINLINE allocArray32AndFreeze #-} + +-- | Create an Array of Word64 of specific size from a list of Word64 +array64 :: Int -> [Word64] -> Array64 +array64 (I# n) l = unsafeDoIO $ IO $ \s -> + case newAlignedPinnedByteArray# (n *# 8#) 8# s of + (# s', mbarr #) -> loop 0# s' mbarr l + where + loop _ st mb [] = freezeArray mb st + loop i st mb ((W64# x):xs) + | booleanPrim (i ==# n) = freezeArray mb st + | otherwise = + let !st' = writeWord64Array# mb i x st + in loop (i +# 1#) st' mb xs + freezeArray mb st = + case unsafeFreezeByteArray# mb st of + (# st', b #) -> (# st', Array64 b #) +{-# NOINLINE array64 #-} + +-- | Create a Mutable Array of Word32 of specific size from a list of Word32 +mutableArray32 :: Int -> [Word32] -> IO MutableArray32 +mutableArray32 (I# n) l = IO $ \s -> + case newAlignedPinnedByteArray# (n *# 4#) 4# s of + (# s', mbarr #) -> loop 0# s' mbarr l + where + loop _ st mb [] = (# st, MutableArray32 mb #) + loop i st mb ((W32# x):xs) + | booleanPrim (i ==# n) = (# st, MutableArray32 mb #) + | otherwise = + let !st' = writeWord32Array# mb i x st + in loop (i +# 1#) st' mb xs + +-- | Create a Mutable Array of BE Word32 aliasing an Addr +mutableArray32FromAddrBE :: Int -> Addr# -> IO MutableArray32 +mutableArray32FromAddrBE (I# n) a = IO $ \s -> + case newAlignedPinnedByteArray# (n *# 4#) 4# s of + (# s', mbarr #) -> loop 0# s' mbarr + where + loop i st mb + | booleanPrim (i ==# n) = (# st, MutableArray32 mb #) + | otherwise = + let !st' = writeWord32Array# mb i (be32Prim (indexWord32OffAddr# a i)) st + in loop (i +# 1#) st' mb + +-- | freeze a Mutable Array of Word32 into a immutable Array of Word32 +mutableArray32Freeze :: MutableArray32 -> IO Array32 +mutableArray32Freeze (MutableArray32 mb) = IO $ \st -> + case unsafeFreezeByteArray# mb st of + (# st', b #) -> (# st', Array32 b #) + +-- | Read a Word8 from an Array +arrayRead8 :: Array8 -> Int -> Word8 +arrayRead8 (Array8 a) (I# o) = W8# (indexWord8OffAddr# a o) +{-# INLINE arrayRead8 #-} + +-- | Read a Word32 from an Array +arrayRead32 :: Array32 -> Int -> Word32 +arrayRead32 (Array32 b) (I# o) = W32# (indexWord32Array# b o) +{-# INLINE arrayRead32 #-} + +-- | Read a Word64 from an Array +arrayRead64 :: Array64 -> Int -> Word64 +arrayRead64 (Array64 b) (I# o) = W64# (indexWord64Array# b o) +{-# INLINE arrayRead64 #-} + +-- | Read a Word32 from a Mutable Array of Word32 +mutableArrayRead32 :: MutableArray32 -> Int -> IO Word32 +mutableArrayRead32 (MutableArray32 m) (I# o) = IO $ \s -> case readWord32Array# m o s of (# s', e #) -> (# s', W32# e #) +{-# INLINE mutableArrayRead32 #-} + +-- | Write a Word32 from a Mutable Array of Word32 +mutableArrayWrite32 :: MutableArray32 -> Int -> Word32 -> IO () +mutableArrayWrite32 (MutableArray32 m) (I# o) (W32# w) = IO $ \s -> let !s' = writeWord32Array# m o w s in (# s', () #) +{-# INLINE mutableArrayWrite32 #-} + +-- | Write into the Mutable Array of Word32 by combining through xor the current value and the new value. +-- +-- > x[i] = x[i] xor value +mutableArrayWriteXor32 :: MutableArray32 -> Int -> Word32 -> IO () +mutableArrayWriteXor32 m o w = + mutableArrayRead32 m o >>= \wOld -> mutableArrayWrite32 m o (wOld `xor` w) +{-# INLINE mutableArrayWriteXor32 #-} diff --git a/bundled/Crypto/Internal/Words.hs b/bundled/Crypto/Internal/Words.hs new file mode 100644 index 0000000..43f391b --- /dev/null +++ b/bundled/Crypto/Internal/Words.hs @@ -0,0 +1,26 @@ +-- | +-- Module : Crypto.Internal.Words +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Extra Word size +-- +module Crypto.Internal.Words + ( Word128(..) + , w64to32 + , w32to64 + ) where + +import Data.Word +import Data.Bits +import Data.Memory.ExtendedWords + +-- | Split a 'Word64' into the highest and lowest 'Word32' +w64to32 :: Word64 -> (Word32, Word32) +w64to32 w = (fromIntegral (w `shiftR` 32), fromIntegral w) + +-- | Reconstruct a 'Word64' from two 'Word32' +w32to64 :: (Word32, Word32) -> Word64 +w32to64 (x1, x2) = ((fromIntegral x1) `shiftL` 32) .|. (fromIntegral x2) diff --git a/bundled/Crypto/Number/Basic.hs b/bundled/Crypto/Number/Basic.hs new file mode 100644 index 0000000..e624b42 --- /dev/null +++ b/bundled/Crypto/Number/Basic.hs @@ -0,0 +1,116 @@ +-- | +-- Module : Crypto.Number.Basic +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good + +{-# LANGUAGE BangPatterns #-} +module Crypto.Number.Basic + ( sqrti + , gcde + , areEven + , log2 + , numBits + , numBytes + , asPowerOf2AndOdd + ) where + +import Data.Bits + +import Crypto.Number.Compat + +-- | @sqrti@ returns two integers @(l,b)@ so that @l <= sqrt i <= b@. +-- The implementation is quite naive, use an approximation for the first number +-- and use a dichotomy algorithm to compute the bound relatively efficiently. +sqrti :: Integer -> (Integer, Integer) +sqrti i + | i < 0 = error "cannot compute negative square root" + | i == 0 = (0,0) + | i == 1 = (1,1) + | i == 2 = (1,2) + | otherwise = loop x0 + where + nbdigits = length $ show i + x0n = (if even nbdigits then nbdigits - 2 else nbdigits - 1) `div` 2 + x0 = if even nbdigits then 2 * 10 ^ x0n else 6 * 10 ^ x0n + loop x = case compare (sq x) i of + LT -> iterUp x + EQ -> (x, x) + GT -> iterDown x + iterUp lb = if sq ub >= i then iter lb ub else iterUp ub + where ub = lb * 2 + iterDown ub = if sq lb >= i then iterDown lb else iter lb ub + where lb = ub `div` 2 + iter lb ub + | lb == ub = (lb, ub) + | lb+1 == ub = (lb, ub) + | otherwise = + let d = (ub - lb) `div` 2 in + if sq (lb + d) >= i + then iter lb (ub-d) + else iter (lb+d) ub + sq a = a * a + +-- | Get the extended GCD of two integer using integer divMod +-- +-- gcde 'a' 'b' find (x,y,gcd(a,b)) where ax + by = d +-- +gcde :: Integer -> Integer -> (Integer, Integer, Integer) +gcde a b = onGmpUnsupported (gmpGcde a b) $ + if d < 0 then (-x,-y,-d) else (x,y,d) + where + (d, x, y) = f (a,1,0) (b,0,1) + f t (0, _, _) = t + f (a', sa, ta) t@(b', sb, tb) = + let (q, r) = a' `divMod` b' in + f t (r, sa - (q * sb), ta - (q * tb)) + +-- | Check if a list of integer are all even +areEven :: [Integer] -> Bool +areEven = and . map even + +-- | Compute the binary logarithm of a integer +log2 :: Integer -> Int +log2 n = onGmpUnsupported (gmpLog2 n) $ imLog 2 n + where + -- http://www.haskell.org/pipermail/haskell-cafe/2008-February/039465.html + imLog b x = if x < b then 0 else (x `div` b^l) `doDiv` l + where + l = 2 * imLog (b * b) x + doDiv x' l' = if x' < b then l' else (x' `div` b) `doDiv` (l' + 1) +{-# INLINE log2 #-} + +-- | Compute the number of bits for an integer +numBits :: Integer -> Int +numBits n = gmpSizeInBits n `onGmpUnsupported` (if n == 0 then 1 else computeBits 0 n) + where computeBits !acc i + | q == 0 = + if r >= 0x80 then acc+8 + else if r >= 0x40 then acc+7 + else if r >= 0x20 then acc+6 + else if r >= 0x10 then acc+5 + else if r >= 0x08 then acc+4 + else if r >= 0x04 then acc+3 + else if r >= 0x02 then acc+2 + else if r >= 0x01 then acc+1 + else acc -- should be catch by previous loop + | otherwise = computeBits (acc+8) q + where (q,r) = i `divMod` 256 + +-- | Compute the number of bytes for an integer +numBytes :: Integer -> Int +numBytes n = gmpSizeInBytes n `onGmpUnsupported` ((numBits n + 7) `div` 8) + +-- | Express an integer as an odd number and a power of 2 +asPowerOf2AndOdd :: Integer -> (Int, Integer) +asPowerOf2AndOdd a + | a == 0 = (0, 0) + | odd a = (0, a) + | a < 0 = let (e, a1) = asPowerOf2AndOdd $ abs a in (e, -a1) + | isPowerOf2 a = (log2 a, 1) + | otherwise = loop a 0 + where + isPowerOf2 n = (n /= 0) && ((n .&. (n - 1)) == 0) + loop n pw = if n `mod` 2 == 0 then loop (n `div` 2) (pw + 1) + else (pw, n) \ No newline at end of file diff --git a/bundled/Crypto/Number/Compat.hs b/bundled/Crypto/Number/Compat.hs new file mode 100644 index 0000000..39acdc8 --- /dev/null +++ b/bundled/Crypto/Number/Compat.hs @@ -0,0 +1,195 @@ +-- | +-- Module : Crypto.Number.Compat +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE UnboxedTuples #-} +module Crypto.Number.Compat + ( GmpSupported(..) + , onGmpUnsupported + , gmpGcde + , gmpLog2 + , gmpPowModSecInteger + , gmpPowModInteger + , gmpInverse + , gmpNextPrime + , gmpTestPrimeMillerRabin + , gmpSizeInBytes + , gmpSizeInBits + , gmpExportInteger + , gmpExportIntegerLE + , gmpImportInteger + , gmpImportIntegerLE + ) where + +#ifndef MIN_VERSION_integer_gmp +#define MIN_VERSION_integer_gmp(a,b,c) 0 +#endif + +#if MIN_VERSION_integer_gmp(0,5,1) +import GHC.Integer.GMP.Internals +import GHC.Base +import GHC.Integer.Logarithms (integerLog2#) +#endif +import Data.Word +import GHC.Ptr (Ptr(..)) + +-- | GMP Supported / Unsupported +data GmpSupported a = GmpSupported a + | GmpUnsupported + deriving (Show,Eq) + +-- | Simple combinator in case the operation is not supported through GMP +onGmpUnsupported :: GmpSupported a -> a -> a +onGmpUnsupported (GmpSupported a) _ = a +onGmpUnsupported GmpUnsupported f = f + +-- | Compute the GCDE of a two integer through GMP +gmpGcde :: Integer -> Integer -> GmpSupported (Integer, Integer, Integer) +#if MIN_VERSION_integer_gmp(0,5,1) +gmpGcde a b = + GmpSupported (s, t, g) + where (# g, s #) = gcdExtInteger a b + t = (g - s * a) `div` b +#else +gmpGcde _ _ = GmpUnsupported +#endif + +-- | Compute the binary logarithm of an integer through GMP +gmpLog2 :: Integer -> GmpSupported Int +#if MIN_VERSION_integer_gmp(0,5,1) +gmpLog2 0 = GmpSupported 0 +gmpLog2 x = GmpSupported (I# (integerLog2# x)) +#else +gmpLog2 _ = GmpUnsupported +#endif + +-- | Compute the power modulus using extra security to remain constant +-- time wise through GMP +gmpPowModSecInteger :: Integer -> Integer -> Integer -> GmpSupported Integer +#if MIN_VERSION_integer_gmp(1,1,0) +gmpPowModSecInteger _ _ _ = GmpUnsupported +#elif MIN_VERSION_integer_gmp(1,0,2) +gmpPowModSecInteger b e m = GmpSupported (powModSecInteger b e m) +#elif MIN_VERSION_integer_gmp(1,0,0) +gmpPowModSecInteger _ _ _ = GmpUnsupported +#elif MIN_VERSION_integer_gmp(0,5,1) +gmpPowModSecInteger b e m = GmpSupported (powModSecInteger b e m) +#else +gmpPowModSecInteger _ _ _ = GmpUnsupported +#endif + +-- | Compute the power modulus through GMP +gmpPowModInteger :: Integer -> Integer -> Integer -> GmpSupported Integer +#if MIN_VERSION_integer_gmp(0,5,1) +gmpPowModInteger b e m = GmpSupported (powModInteger b e m) +#else +gmpPowModInteger _ _ _ = GmpUnsupported +#endif + +-- | Inverse modulus of a number through GMP +gmpInverse :: Integer -> Integer -> GmpSupported (Maybe Integer) +#if MIN_VERSION_integer_gmp(0,5,1) +gmpInverse g m + | r == 0 = GmpSupported Nothing + | otherwise = GmpSupported (Just r) + where r = recipModInteger g m +#else +gmpInverse _ _ = GmpUnsupported +#endif + +-- | Get the next prime from a specific value through GMP +gmpNextPrime :: Integer -> GmpSupported Integer +#if MIN_VERSION_integer_gmp(1,1,0) +gmpNextPrime _ = GmpUnsupported +#elif MIN_VERSION_integer_gmp(0,5,1) +gmpNextPrime n = GmpSupported (nextPrimeInteger n) +#else +gmpNextPrime _ = GmpUnsupported +#endif + +-- | Test if a number is prime using Miller Rabin +gmpTestPrimeMillerRabin :: Int -> Integer -> GmpSupported Bool +#if MIN_VERSION_integer_gmp(1,1,0) +gmpTestPrimeMillerRabin _ _ = GmpUnsupported +#elif MIN_VERSION_integer_gmp(0,5,1) +gmpTestPrimeMillerRabin (I# tries) !n = GmpSupported $ + case testPrimeInteger n tries of + 0# -> False + _ -> True +#else +gmpTestPrimeMillerRabin _ _ = GmpUnsupported +#endif + +-- | Return the size in bytes of an integer +gmpSizeInBytes :: Integer -> GmpSupported Int +#if MIN_VERSION_integer_gmp(0,5,1) +gmpSizeInBytes n = GmpSupported (I# (word2Int# (sizeInBaseInteger n 256#))) +#else +gmpSizeInBytes _ = GmpUnsupported +#endif + +-- | Return the size in bits of an integer +gmpSizeInBits :: Integer -> GmpSupported Int +#if MIN_VERSION_integer_gmp(0,5,1) +gmpSizeInBits n = GmpSupported (I# (word2Int# (sizeInBaseInteger n 2#))) +#else +gmpSizeInBits _ = GmpUnsupported +#endif + +-- | Export an integer to a memory (big-endian) +gmpExportInteger :: Integer -> Ptr Word8 -> GmpSupported (IO ()) +#if MIN_VERSION_integer_gmp(1,0,0) +gmpExportInteger n (Ptr addr) = GmpSupported $ do + _ <- exportIntegerToAddr n addr 1# + return () +#elif MIN_VERSION_integer_gmp(0,5,1) +gmpExportInteger n (Ptr addr) = GmpSupported $ IO $ \s -> + case exportIntegerToAddr n addr 1# s of + (# s2, _ #) -> (# s2, () #) +#else +gmpExportInteger _ _ = GmpUnsupported +#endif + +-- | Export an integer to a memory (little-endian) +gmpExportIntegerLE :: Integer -> Ptr Word8 -> GmpSupported (IO ()) +#if MIN_VERSION_integer_gmp(1,0,0) +gmpExportIntegerLE n (Ptr addr) = GmpSupported $ do + _ <- exportIntegerToAddr n addr 0# + return () +#elif MIN_VERSION_integer_gmp(0,5,1) +gmpExportIntegerLE n (Ptr addr) = GmpSupported $ IO $ \s -> + case exportIntegerToAddr n addr 0# s of + (# s2, _ #) -> (# s2, () #) +#else +gmpExportIntegerLE _ _ = GmpUnsupported +#endif + +-- | Import an integer from a memory (big-endian) +gmpImportInteger :: Int -> Ptr Word8 -> GmpSupported (IO Integer) +#if MIN_VERSION_integer_gmp(1,0,0) +gmpImportInteger (I# n) (Ptr addr) = GmpSupported $ + importIntegerFromAddr addr (int2Word# n) 1# +#elif MIN_VERSION_integer_gmp(0,5,1) +gmpImportInteger (I# n) (Ptr addr) = GmpSupported $ IO $ \s -> + importIntegerFromAddr addr (int2Word# n) 1# s +#else +gmpImportInteger _ _ = GmpUnsupported +#endif + +-- | Import an integer from a memory (little-endian) +gmpImportIntegerLE :: Int -> Ptr Word8 -> GmpSupported (IO Integer) +#if MIN_VERSION_integer_gmp(1,0,0) +gmpImportIntegerLE (I# n) (Ptr addr) = GmpSupported $ + importIntegerFromAddr addr (int2Word# n) 0# +#elif MIN_VERSION_integer_gmp(0,5,1) +gmpImportIntegerLE (I# n) (Ptr addr) = GmpSupported $ IO $ \s -> + importIntegerFromAddr addr (int2Word# n) 0# s +#else +gmpImportIntegerLE _ _ = GmpUnsupported +#endif diff --git a/bundled/Crypto/Number/F2m.hs b/bundled/Crypto/Number/F2m.hs new file mode 100644 index 0000000..6ca2604 --- /dev/null +++ b/bundled/Crypto/Number/F2m.hs @@ -0,0 +1,169 @@ +-- | +-- Module : Crypto.Math.F2m +-- License : BSD-style +-- Maintainer : Danny Navarro +-- Stability : experimental +-- Portability : Good +-- +-- This module provides basic arithmetic operations over F₂m. Performance is +-- not optimal and it doesn't provide protection against timing +-- attacks. The 'm' parameter is implicitly derived from the irreducible +-- polynomial where applicable. + +module Crypto.Number.F2m + ( BinaryPolynomial + , addF2m + , mulF2m + , squareF2m' + , squareF2m + , powF2m + , modF2m + , sqrtF2m + , invF2m + , divF2m + ) where + +import Data.Bits (xor, shift, testBit, setBit) +import Data.List +import Crypto.Number.Basic + +-- | Binary Polynomial represented by an integer +type BinaryPolynomial = Integer + +-- | Addition over F₂m. This is just a synonym of 'xor'. +addF2m :: Integer + -> Integer + -> Integer +addF2m = xor +{-# INLINE addF2m #-} + +-- | Reduction by modulo over F₂m. +-- +-- This function is undefined for negative arguments, because their bit +-- representation is platform-dependent. Zero modulus is also prohibited. +modF2m :: BinaryPolynomial -- ^ Modulus + -> Integer + -> Integer +modF2m fx i + | fx < 0 || i < 0 = error "modF2m: negative number represent no binary polynomial" + | fx == 0 = error "modF2m: cannot divide by zero polynomial" + | fx == 1 = 0 + | otherwise = go i + where + lfx = log2 fx + go n | s == 0 = n `addF2m` fx + | s < 0 = n + | otherwise = go $ n `addF2m` shift fx s + where s = log2 n - lfx +{-# INLINE modF2m #-} + +-- | Multiplication over F₂m. +-- +-- This function is undefined for negative arguments, because their bit +-- representation is platform-dependent. Zero modulus is also prohibited. +mulF2m :: BinaryPolynomial -- ^ Modulus + -> Integer + -> Integer + -> Integer +mulF2m fx n1 n2 + | fx < 0 + || n1 < 0 + || n2 < 0 = error "mulF2m: negative number represent no binary polynomial" + | fx == 0 = error "mulF2m: cannot multiply modulo zero polynomial" + | otherwise = modF2m fx $ go (if n2 `mod` 2 == 1 then n1 else 0) (log2 n2) + where + go n s | s == 0 = n + | otherwise = if testBit n2 s + then go (n `addF2m` shift n1 s) (s - 1) + else go n (s - 1) +{-# INLINABLE mulF2m #-} + +-- | Squaring over F₂m. +-- +-- This function is undefined for negative arguments, because their bit +-- representation is platform-dependent. Zero modulus is also prohibited. +squareF2m :: BinaryPolynomial -- ^ Modulus + -> Integer + -> Integer +squareF2m fx = modF2m fx . squareF2m' +{-# INLINE squareF2m #-} + +-- | Squaring over F₂m without reduction by modulo. +-- +-- The implementation utilizes the fact that for binary polynomial S(x) we have +-- S(x)^2 = S(x^2). In other words, insert a zero bit between every bits of argument: 1101 -> 1010001. +-- +-- This function is undefined for negative arguments, because their bit +-- representation is platform-dependent. +squareF2m' :: Integer + -> Integer +squareF2m' n + | n < 0 = error "mulF2m: negative number represent no binary polynomial" + | otherwise = foldl' (\acc s -> if testBit n s then setBit acc (2 * s) else acc) 0 [0 .. log2 n] +{-# INLINE squareF2m' #-} + +-- | Exponentiation in F₂m by computing @a^b mod fx@. +-- +-- This implements an exponentiation by squaring based solution. It inherits the +-- same restrictions as 'squareF2m'. Negative exponents are disallowed. +powF2m :: BinaryPolynomial -- ^Modulus + -> Integer -- ^a + -> Integer -- ^b + -> Integer +powF2m fx a b + | b < 0 = error "powF2m: negative exponents disallowed" + | b == 0 = if fx > 1 then 1 else 0 + | even b = squareF2m fx x + | otherwise = mulF2m fx a (squareF2m' x) + where x = powF2m fx a (b `div` 2) + +-- | Square rooot in F₂m. +-- +-- We exploit the fact that @a^(2^m) = a@, or in particular, @a^(2^m - 1) = 1@ +-- from a classical result by Lagrange. Thus the square root is simply @a^(2^(m +-- - 1))@. +sqrtF2m :: BinaryPolynomial -- ^Modulus + -> Integer -- ^a + -> Integer +sqrtF2m fx a = go (log2 fx - 1) a + where go 0 x = x + go n x = go (n - 1) (squareF2m fx x) + +-- | Extended GCD algorithm for polynomials. For @a@ and @b@ returns @(g, u, v)@ such that @a * u + b * v == g@. +-- +-- Reference: https://en.wikipedia.org/wiki/Polynomial_greatest_common_divisor#B.C3.A9zout.27s_identity_and_extended_GCD_algorithm +gcdF2m :: Integer + -> Integer + -> (Integer, Integer, Integer) +gcdF2m a b = go (a, b, 1, 0, 0, 1) + where + go (g, 0, u, _, v, _) + = (g, u, v) + go (r0, r1, s0, s1, t0, t1) + = go (r1, r0 `addF2m` shift r1 j, s1, s0 `addF2m` shift s1 j, t1, t0 `addF2m` shift t1 j) + where j = max 0 (log2 r0 - log2 r1) + +-- | Modular inversion over F₂m. +-- If @n@ doesn't have an inverse, 'Nothing' is returned. +-- +-- This function is undefined for negative arguments, because their bit +-- representation is platform-dependent. Zero modulus is also prohibited. +invF2m :: BinaryPolynomial -- ^ Modulus + -> Integer + -> Maybe Integer +invF2m fx n = if g == 1 then Just (modF2m fx u) else Nothing + where + (g, u, _) = gcdF2m n fx +{-# INLINABLE invF2m #-} + +-- | Division over F₂m. If the dividend doesn't have an inverse it returns +-- 'Nothing'. +-- +-- This function is undefined for negative arguments, because their bit +-- representation is platform-dependent. Zero modulus is also prohibited. +divF2m :: BinaryPolynomial -- ^ Modulus + -> Integer -- ^ Dividend + -> Integer -- ^ Divisor + -> Maybe Integer -- ^ Quotient +divF2m fx n1 n2 = mulF2m fx n1 <$> invF2m fx n2 +{-# INLINE divF2m #-} diff --git a/bundled/Crypto/Number/Generate.hs b/bundled/Crypto/Number/Generate.hs new file mode 100644 index 0000000..c2103c8 --- /dev/null +++ b/bundled/Crypto/Number/Generate.hs @@ -0,0 +1,123 @@ +-- | +-- Module : Crypto.Number.Generate +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good + +module Crypto.Number.Generate + ( GenTopPolicy(..) + , generateParams + , generateMax + , generateBetween + ) where + +import Crypto.Internal.Imports +import Crypto.Number.Basic +import Crypto.Number.Serialize +import Crypto.Random.Types +import Control.Monad (when) +import Foreign.Ptr +import Foreign.Storable +import Data.Bits ((.|.), (.&.), shiftL, complement, testBit) +import Crypto.Internal.ByteArray (ScrubbedBytes) +import qualified Crypto.Internal.ByteArray as B + + +-- | Top bits policy when generating a number +data GenTopPolicy = + SetHighest -- ^ set the highest bit + | SetTwoHighest -- ^ set the two highest bit + deriving (Show,Eq) + +-- | Generate a number for a specific size of bits, +-- and optionaly set bottom and top bits +-- +-- If the top bit policy is 'Nothing', then nothing is +-- done on the highest bit (it's whatever the random generator set). +-- +-- If @generateOdd is set to 'True', then the number generated +-- is guaranteed to be odd. Otherwise it will be whatever is generated +-- +generateParams :: MonadRandom m + => Int -- ^ number of bits + -> Maybe GenTopPolicy -- ^ top bit policy + -> Bool -- ^ force the number to be odd + -> m Integer +generateParams bits genTopPolicy generateOdd + | bits <= 0 = return 0 + | otherwise = os2ip . tweak <$> getRandomBytes bytes + where + tweak :: ScrubbedBytes -> ScrubbedBytes + tweak orig = B.copyAndFreeze orig $ \p0 -> do + let p1 = p0 `plusPtr` 1 + pEnd = p0 `plusPtr` (bytes - 1) + case genTopPolicy of + Nothing -> return () + Just SetHighest -> p0 |= (1 `shiftL` bit) + Just SetTwoHighest + | bit == 0 -> do p0 $= 0x1 + p1 |= 0x80 + | otherwise -> p0 |= (0x3 `shiftL` (bit - 1)) + p0 &= (complement $ mask) + when generateOdd (pEnd |= 0x1) + + ($=) :: Ptr Word8 -> Word8 -> IO () + ($=) p w = poke p w + + (|=) :: Ptr Word8 -> Word8 -> IO () + (|=) p w = peek p >>= \v -> poke p (v .|. w) + + (&=) :: Ptr Word8 -> Word8 -> IO () + (&=) p w = peek p >>= \v -> poke p (v .&. w) + + bytes = (bits + 7) `div` 8; + bit = (bits - 1) `mod` 8; + mask = 0xff `shiftL` (bit + 1); + +-- | Generate a positive integer x, s.t. 0 <= x < range +generateMax :: MonadRandom m + => Integer -- ^ range + -> m Integer +generateMax range + | range <= 1 = return 0 + | range < 127 = generateSimple + | canOverGenerate = loopGenerateOver tries + | otherwise = loopGenerate tries + where + -- this "generator" is mostly for quickcheck benefits. it'll be biased if + -- range is not a multiple of 2, but overall, no security should be + -- assumed for a number between 0 and 127. + generateSimple = flip mod range `fmap` generateParams bits Nothing False + + loopGenerate count + | count == 0 = error $ "internal: generateMax(" ++ show range ++ " bits=" ++ show bits ++ ") (normal) doesn't seems to work properly" + | otherwise = do + r <- generateParams bits Nothing False + if isValid r then return r else loopGenerate (count-1) + + loopGenerateOver count + | count == 0 = error $ "internal: generateMax(" ++ show range ++ " bits=" ++ show bits ++ ") (over) doesn't seems to work properly" + | otherwise = do + r <- generateParams (bits+1) Nothing False + let r2 = r - range + r3 = r2 - range + if isValid r + then return r + else if isValid r2 + then return r2 + else if isValid r3 + then return r3 + else loopGenerateOver (count-1) + + bits = numBits range + canOverGenerate = bits > 3 && not (range `testBit` (bits-2)) && not (range `testBit` (bits-3)) + + isValid n = n < range + + tries :: Int + tries = 100 + +-- | generate a number between the inclusive bound [low,high]. +generateBetween :: MonadRandom m => Integer -> Integer -> m Integer +generateBetween low high = (low +) <$> generateMax (high - low + 1) diff --git a/bundled/Crypto/Number/ModArithmetic.hs b/bundled/Crypto/Number/ModArithmetic.hs new file mode 100644 index 0000000..edb2679 --- /dev/null +++ b/bundled/Crypto/Number/ModArithmetic.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Crypto.Number.ModArithmetic +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good + +module Crypto.Number.ModArithmetic + ( + -- * Exponentiation + expSafe + , expFast + -- * Inverse computing + , inverse + , inverseCoprimes + , inverseFermat + -- * Squares + , jacobi + , squareRoot + ) where + +import Control.Exception (throw, Exception) +import Crypto.Number.Basic +import Crypto.Number.Compat + +-- | Raised when two numbers are supposed to be coprimes but are not. +data CoprimesAssertionError = CoprimesAssertionError + deriving (Show) + +instance Exception CoprimesAssertionError + +-- | Compute the modular exponentiation of base^exponent using +-- algorithms design to avoid side channels and timing measurement +-- +-- Modulo need to be odd otherwise the normal fast modular exponentiation +-- is used. +-- +-- When used with integer-simple, this function is not different +-- from expFast, and thus provide the same unstudied and dubious +-- timing and side channels claims. +-- +-- Before GHC 8.4.2, powModSecInteger is missing from integer-gmp, +-- so expSafe has the same security as expFast. +expSafe :: Integer -- ^ base + -> Integer -- ^ exponent + -> Integer -- ^ modulo + -> Integer -- ^ result +expSafe b e m + | odd m = gmpPowModSecInteger b e m `onGmpUnsupported` + (gmpPowModInteger b e m `onGmpUnsupported` + exponentiation b e m) + | otherwise = gmpPowModInteger b e m `onGmpUnsupported` + exponentiation b e m + +-- | Compute the modular exponentiation of base^exponent using +-- the fastest algorithm without any consideration for +-- hiding parameters. +-- +-- Use this function when all the parameters are public, +-- otherwise 'expSafe' should be preferred. +expFast :: Integer -- ^ base + -> Integer -- ^ exponent + -> Integer -- ^ modulo + -> Integer -- ^ result +expFast b e m = gmpPowModInteger b e m `onGmpUnsupported` exponentiation b e m + +-- | @exponentiation@ computes modular exponentiation as /b^e mod m/ +-- using repetitive squaring. +exponentiation :: Integer -> Integer -> Integer -> Integer +exponentiation b e m + | b == 1 = b + | e == 0 = 1 + | e == 1 = b `mod` m + | even e = let p = exponentiation b (e `div` 2) m `mod` m + in (p^(2::Integer)) `mod` m + | otherwise = (b * exponentiation b (e-1) m) `mod` m + +-- | @inverse@ computes the modular inverse as in /g^(-1) mod m/. +inverse :: Integer -> Integer -> Maybe Integer +inverse g m = gmpInverse g m `onGmpUnsupported` v + where + v + | d > 1 = Nothing + | otherwise = Just (x `mod` m) + (x,_,d) = gcde g m + +-- | Compute the modular inverse of two coprime numbers. +-- This is equivalent to inverse except that the result +-- is known to exists. +-- +-- If the numbers are not defined as coprime, this function +-- will raise a 'CoprimesAssertionError'. +inverseCoprimes :: Integer -> Integer -> Integer +inverseCoprimes g m = + case inverse g m of + Nothing -> throw CoprimesAssertionError + Just i -> i + +-- | Computes the Jacobi symbol (a/n). +-- 0 ≤ a < n; n ≥ 3 and odd. +-- +-- The Legendre and Jacobi symbols are indistinguishable exactly when the +-- lower argument is an odd prime, in which case they have the same value. +-- +-- See algorithm 2.149 in "Handbook of Applied Cryptography" by Alfred J. Menezes et al. +jacobi :: Integer -> Integer -> Maybe Integer +jacobi a n + | n < 3 || even n = Nothing + | a == 0 || a == 1 = Just a + | n <= a = jacobi (a `mod` n) n + | a < 0 = + let b = if n `mod` 4 == 1 then 1 else -1 + in fmap (*b) (jacobi (-a) n) + | otherwise = + let (e, a1) = asPowerOf2AndOdd a + nMod8 = n `mod` 8 + nMod4 = n `mod` 4 + a1Mod4 = a1 `mod` 4 + s' = if even e || nMod8 == 1 || nMod8 == 7 then 1 else -1 + s = if nMod4 == 3 && a1Mod4 == 3 then -s' else s' + n1 = n `mod` a1 + in if a1 == 1 then Just s + else fmap (*s) (jacobi n1 a1) + +-- | Modular inverse using Fermat's little theorem. This works only when +-- the modulus is prime but avoids side channels like in 'expSafe'. +inverseFermat :: Integer -> Integer -> Integer +inverseFermat g p = expSafe g (p - 2) p + +-- | Raised when the assumption about the modulus is invalid. +data ModulusAssertionError = ModulusAssertionError + deriving (Show) + +instance Exception ModulusAssertionError + +-- | Modular square root of @g@ modulo a prime @p@. +-- +-- If the modulus is found not to be prime, the function will raise a +-- 'ModulusAssertionError'. +-- +-- This implementation is variable time and should be used with public +-- parameters only. +squareRoot :: Integer -> Integer -> Maybe Integer +squareRoot p + | p < 2 = throw ModulusAssertionError + | otherwise = + case p `divMod` 8 of + (v, 3) -> method1 (2 * v + 1) + (v, 7) -> method1 (2 * v + 2) + (u, 5) -> method2 u + (_, 1) -> tonelliShanks p + (0, 2) -> \a -> Just (if even a then 0 else 1) + _ -> throw ModulusAssertionError + + where + x `eqMod` y = (x - y) `mod` p == 0 + + validate g y | (y * y) `eqMod` g = Just y + | otherwise = Nothing + + -- p == 4u + 3 and u' == u + 1 + method1 u' g = + let y = expFast g u' p + in validate g y + + -- p == 8u + 5 + method2 u g = + let gamma = expFast (2 * g) u p + g_gamma = g * gamma + i = (2 * g_gamma * gamma) `mod` p + y = (g_gamma * (i - 1)) `mod` p + in validate g y + +tonelliShanks :: Integer -> Integer -> Maybe Integer +tonelliShanks p a + | aa == 0 = Just 0 + | otherwise = + case expFast aa p2 p of + b | b == p1 -> Nothing + | b == 1 -> Just $ go (expFast aa ((s + 1) `div` 2) p) + (expFast aa s p) + (expFast n s p) + e + | otherwise -> throw ModulusAssertionError + where + aa = a `mod` p + p1 = p - 1 + p2 = p1 `div` 2 + n = findN 2 + + x `mul` y = (x * y) `mod` p + + pow2m 0 x = x + pow2m i x = pow2m (i - 1) (x `mul` x) + + (e, s) = asPowerOf2AndOdd p1 + + -- find a quadratic non-residue + findN i + | expFast i p2 p == p1 = i + | otherwise = findN (i + 1) + + -- find m such that b^(2^m) == 1 (mod p) + findM b i + | b == 1 = i + | otherwise = findM (b `mul` b) (i + 1) + + go !x b g !r + | b == 1 = x + | otherwise = + let r' = findM b 0 + z = pow2m (r - r' - 1) g + x' = x `mul` z + b' = b `mul` g' + g' = z `mul` z + in go x' b' g' r' diff --git a/bundled/Crypto/Number/Nat.hs b/bundled/Crypto/Number/Nat.hs new file mode 100644 index 0000000..8620bf4 --- /dev/null +++ b/bundled/Crypto/Number/Nat.hs @@ -0,0 +1,63 @@ +-- | +-- Module : Crypto.Number.Nat +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +-- Numbers at type level. +-- +-- This module provides extensions to "GHC.TypeLits" and "GHC.TypeNats" useful +-- to work with cryptographic algorithms parameterized with a variable bit +-- length. Constraints like @'IsDivisibleBy8' n@ ensure that the type-level +-- parameter is applicable to the algorithm. +-- +-- Functions are also provided to test whether constraints are satisfied from +-- values known at runtime. The following example shows how to discharge +-- 'IsDivisibleBy8' in a computation @fn@ requiring this constraint: +-- +-- > withDivisibleBy8 :: Integer +-- > -> (forall proxy n . (KnownNat n, IsDivisibleBy8 n) => proxy n -> a) +-- > -> Maybe a +-- > withDivisibleBy8 len fn = do +-- > SomeNat p <- someNatVal len +-- > Refl <- isDivisibleBy8 p +-- > pure (fn p) +-- +-- Function @withDivisibleBy8@ above returns 'Nothing' when the argument @len@ +-- is negative or not divisible by 8. +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +module Crypto.Number.Nat + ( type IsDivisibleBy8 + , type IsAtMost, type IsAtLeast + , isDivisibleBy8 + , isAtMost + , isAtLeast + ) where + +import Data.Type.Equality +import GHC.TypeLits +import Unsafe.Coerce (unsafeCoerce) + +import Crypto.Internal.Nat + +-- | get a runtime proof that the constraint @'IsDivisibleBy8' n@ is satified +isDivisibleBy8 :: KnownNat n => proxy n -> Maybe (IsDiv8 n n :~: 'True) +isDivisibleBy8 n + | mod (natVal n) 8 == 0 = Just (unsafeCoerce Refl) + | otherwise = Nothing + +-- | get a runtime proof that the constraint @'IsAtMost' value bound@ is +-- satified +isAtMost :: (KnownNat value, KnownNat bound) + => proxy value -> proxy' bound -> Maybe ((value <=? bound) :~: 'True) +isAtMost x y + | natVal x <= natVal y = Just (unsafeCoerce Refl) + | otherwise = Nothing + +-- | get a runtime proof that the constraint @'IsAtLeast' value bound@ is +-- satified +isAtLeast :: (KnownNat value, KnownNat bound) + => proxy value -> proxy' bound -> Maybe ((bound <=? value) :~: 'True) +isAtLeast = flip isAtMost diff --git a/bundled/Crypto/Number/Prime.hs b/bundled/Crypto/Number/Prime.hs new file mode 100644 index 0000000..808f1e0 --- /dev/null +++ b/bundled/Crypto/Number/Prime.hs @@ -0,0 +1,235 @@ +-- | +-- Module : Crypto.Number.Prime +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good + +{-# LANGUAGE BangPatterns #-} +module Crypto.Number.Prime + ( + generatePrime + , generateSafePrime + , isProbablyPrime + , findPrimeFrom + , findPrimeFromWith + , primalityTestMillerRabin + , primalityTestNaive + , primalityTestFermat + , isCoprime + ) where + +import Crypto.Number.Compat +import Crypto.Number.Generate +import Crypto.Number.Basic (sqrti, gcde) +import Crypto.Number.ModArithmetic (expSafe) +import Crypto.Random.Types +import Crypto.Random.Probabilistic +import Crypto.Error + +import Data.Bits + +-- | Returns if the number is probably prime. +-- First a list of small primes are implicitely tested for divisibility, +-- then a fermat primality test is used with arbitrary numbers and +-- then the Miller Rabin algorithm is used with an accuracy of 30 recursions. +isProbablyPrime :: Integer -> Bool +isProbablyPrime !n + | any (\p -> p `divides` n) (filter (< n) firstPrimes) = False + | n >= 2 && n <= 2903 = True + | primalityTestFermat 50 (n `div` 2) n = primalityTestMillerRabin 30 n + | otherwise = False + +-- | Generate a prime number of the required bitsize (i.e. in the range +-- [2^(b-1)+2^(b-2), 2^b)). +-- +-- May throw a 'CryptoError_PrimeSizeInvalid' if the requested size is less +-- than 5 bits, as the smallest prime meeting these conditions is 29. +-- This function requires that the two highest bits are set, so that when +-- multiplied with another prime to create a key, it is guaranteed to be of +-- the proper size. +generatePrime :: MonadRandom m => Int -> m Integer +generatePrime bits = do + if bits < 5 then + throwCryptoError $ CryptoFailed $ CryptoError_PrimeSizeInvalid + else do + sp <- generateParams bits (Just SetTwoHighest) True + let prime = findPrimeFrom sp + if prime < 1 `shiftL` bits then + return $ prime + else generatePrime bits + +-- | Generate a prime number of the form 2p+1 where p is also prime. +-- it is also knowed as a Sophie Germaine prime or safe prime. +-- +-- The number of safe prime is significantly smaller to the number of prime, +-- as such it shouldn't be used if this number is supposed to be kept safe. +-- +-- May throw a 'CryptoError_PrimeSizeInvalid' if the requested size is less than +-- 6 bits, as the smallest safe prime with the two highest bits set is 59. +generateSafePrime :: MonadRandom m => Int -> m Integer +generateSafePrime bits = do + if bits < 6 then + throwCryptoError $ CryptoFailed $ CryptoError_PrimeSizeInvalid + else do + sp <- generateParams bits (Just SetTwoHighest) True + let p = findPrimeFromWith (\i -> isProbablyPrime (2*i+1)) (sp `div` 2) + let val = 2 * p + 1 + if val < 1 `shiftL` bits then + return $ val + else generateSafePrime bits + +-- | Find a prime from a starting point where the property hold. +findPrimeFromWith :: (Integer -> Bool) -> Integer -> Integer +findPrimeFromWith prop !n + | even n = findPrimeFromWith prop (n+1) + | otherwise = + if not (isProbablyPrime n) + then findPrimeFromWith prop (n+2) + else + if prop n + then n + else findPrimeFromWith prop (n+2) + +-- | Find a prime from a starting point with no specific property. +findPrimeFrom :: Integer -> Integer +findPrimeFrom n = + case gmpNextPrime n of + GmpSupported p -> p + GmpUnsupported -> findPrimeFromWith (\_ -> True) n + +-- | Miller Rabin algorithm return if the number is probably prime or composite. +-- the tries parameter is the number of recursion, that determines the accuracy of the test. +primalityTestMillerRabin :: Int -> Integer -> Bool +primalityTestMillerRabin tries !n = + case gmpTestPrimeMillerRabin tries n of + GmpSupported b -> b + GmpUnsupported -> probabilistic run + where + run + | n <= 3 = error "Miller-Rabin requires tested value to be > 3" + | even n = return False + | tries <= 0 = error "Miller-Rabin tries need to be > 0" + | otherwise = loop <$> generateTries tries + + !nm1 = n-1 + !nm2 = n-2 + + (!s,!d) = (factorise 0 nm1) + + generateTries 0 = return [] + generateTries t = do + v <- generateBetween 2 nm2 + vs <- generateTries (t-1) + return (v:vs) + + -- factorise n-1 into the form 2^s*d + factorise :: Integer -> Integer -> (Integer, Integer) + factorise !si !vi + | vi `testBit` 0 = (si, vi) + | otherwise = factorise (si+1) (vi `shiftR` 1) -- probably faster to not shift v continuously, but just once. + expmod = expSafe + + -- when iteration reach zero, we have a probable prime + loop [] = True + loop (w:ws) = let x = expmod w d n + in if x == (1 :: Integer) || x == nm1 + then loop ws + else loop' ws ((x*x) `mod` n) 1 + + -- loop from 1 to s-1. if we reach the end then it's composite + loop' ws !x2 !r + | r == s = False + | x2 == 1 = False + | x2 /= nm1 = loop' ws ((x2*x2) `mod` n) (r+1) + | otherwise = loop ws + +{- + n < z -> witness to test + 1373653 [2,3] + 9080191 [31,73] + 4759123141 [2,7,61] + 2152302898747 [2,3,5,7,11] + 3474749660383 [2,3,5,7,11,13] + 341550071728321 [2,3,5,7,11,13,17] +-} + +-- | Probabilitic Test using Fermat primility test. +-- Beware of Carmichael numbers that are Fermat liars, i.e. this test +-- is useless for them. always combines with some other test. +primalityTestFermat :: Int -- ^ number of iterations of the algorithm + -> Integer -- ^ starting a + -> Integer -- ^ number to test for primality + -> Bool +primalityTestFermat n a p = and $ map expTest [a..(a+fromIntegral n)] + where !pm1 = p-1 + expTest i = expSafe i pm1 p == 1 + +-- | Test naively is integer is prime. +-- while naive, we skip even number and stop iteration at i > sqrt(n) +primalityTestNaive :: Integer -> Bool +primalityTestNaive n + | n <= 1 = False + | n == 2 = True + | even n = False + | otherwise = search 3 + where !ubound = snd $ sqrti n + search !i + | i > ubound = True + | i `divides` n = False + | otherwise = search (i+2) + +-- | Test is two integer are coprime to each other +isCoprime :: Integer -> Integer -> Bool +isCoprime m n = case gcde m n of (_,_,d) -> d == 1 + +-- | List of the first primes till 2903. +firstPrimes :: [Integer] +firstPrimes = + [ 2 , 3 , 5 , 7 , 11 , 13 , 17 , 19 , 23 , 29 + , 31 , 37 , 41 , 43 , 47 , 53 , 59 , 61 , 67 , 71 + , 73 , 79 , 83 , 89 , 97 , 101 , 103 , 107 , 109 , 113 + , 127 , 131 , 137 , 139 , 149 , 151 , 157 , 163 , 167 , 173 + , 179 , 181 , 191 , 193 , 197 , 199 , 211 , 223 , 227 , 229 + , 233 , 239 , 241 , 251 , 257 , 263 , 269 , 271 , 277 , 281 + , 283 , 293 , 307 , 311 , 313 , 317 , 331 , 337 , 347 , 349 + , 353 , 359 , 367 , 373 , 379 , 383 , 389 , 397 , 401 , 409 + , 419 , 421 , 431 , 433 , 439 , 443 , 449 , 457 , 461 , 463 + , 467 , 479 , 487 , 491 , 499 , 503 , 509 , 521 , 523 , 541 + , 547 , 557 , 563 , 569 , 571 , 577 , 587 , 593 , 599 , 601 + , 607 , 613 , 617 , 619 , 631 , 641 , 643 , 647 , 653 , 659 + , 661 , 673 , 677 , 683 , 691 , 701 , 709 , 719 , 727 , 733 + , 739 , 743 , 751 , 757 , 761 , 769 , 773 , 787 , 797 , 809 + , 811 , 821 , 823 , 827 , 829 , 839 , 853 , 857 , 859 , 863 + , 877 , 881 , 883 , 887 , 907 , 911 , 919 , 929 , 937 , 941 + , 947 , 953 , 967 , 971 , 977 , 983 , 991 , 997 , 1009 , 1013 + , 1019 , 1021 , 1031 , 1033 , 1039 , 1049 , 1051 , 1061 , 1063 , 1069 + , 1087 , 1091 , 1093 , 1097 , 1103 , 1109 , 1117 , 1123 , 1129 , 1151 + , 1153 , 1163 , 1171 , 1181 , 1187 , 1193 , 1201 , 1213 , 1217 , 1223 + , 1229 , 1231 , 1237 , 1249 , 1259 , 1277 , 1279 , 1283 , 1289 , 1291 + , 1297 , 1301 , 1303 , 1307 , 1319 , 1321 , 1327 , 1361 , 1367 , 1373 + , 1381 , 1399 , 1409 , 1423 , 1427 , 1429 , 1433 , 1439 , 1447 , 1451 + , 1453 , 1459 , 1471 , 1481 , 1483 , 1487 , 1489 , 1493 , 1499 , 1511 + , 1523 , 1531 , 1543 , 1549 , 1553 , 1559 , 1567 , 1571 , 1579 , 1583 + , 1597 , 1601 , 1607 , 1609 , 1613 , 1619 , 1621 , 1627 , 1637 , 1657 + , 1663 , 1667 , 1669 , 1693 , 1697 , 1699 , 1709 , 1721 , 1723 , 1733 + , 1741 , 1747 , 1753 , 1759 , 1777 , 1783 , 1787 , 1789 , 1801 , 1811 + , 1823 , 1831 , 1847 , 1861 , 1867 , 1871 , 1873 , 1877 , 1879 , 1889 + , 1901 , 1907 , 1913 , 1931 , 1933 , 1949 , 1951 , 1973 , 1979 , 1987 + , 1993 , 1997 , 1999 , 2003 , 2011 , 2017 , 2027 , 2029 , 2039 , 2053 + , 2063 , 2069 , 2081 , 2083 , 2087 , 2089 , 2099 , 2111 , 2113 , 2129 + , 2131 , 2137 , 2141 , 2143 , 2153 , 2161 , 2179 , 2203 , 2207 , 2213 + , 2221 , 2237 , 2239 , 2243 , 2251 , 2267 , 2269 , 2273 , 2281 , 2287 + , 2293 , 2297 , 2309 , 2311 , 2333 , 2339 , 2341 , 2347 , 2351 , 2357 + , 2371 , 2377 , 2381 , 2383 , 2389 , 2393 , 2399 , 2411 , 2417 , 2423 + , 2437 , 2441 , 2447 , 2459 , 2467 , 2473 , 2477 , 2503 , 2521 , 2531 + , 2539 , 2543 , 2549 , 2551 , 2557 , 2579 , 2591 , 2593 , 2609 , 2617 + , 2621 , 2633 , 2647 , 2657 , 2659 , 2663 , 2671 , 2677 , 2683 , 2687 + , 2689 , 2693 , 2699 , 2707 , 2711 , 2713 , 2719 , 2729 , 2731 , 2741 + , 2749 , 2753 , 2767 , 2777 , 2789 , 2791 , 2797 , 2801 , 2803 , 2819 + , 2833 , 2837 , 2843 , 2851 , 2857 , 2861 , 2879 , 2887 , 2897 , 2903 + ] + +{-# INLINE divides #-} +divides :: Integer -> Integer -> Bool +divides i n = n `mod` i == 0 diff --git a/bundled/Crypto/Number/Serialize.hs b/bundled/Crypto/Number/Serialize.hs new file mode 100644 index 0000000..858e848 --- /dev/null +++ b/bundled/Crypto/Number/Serialize.hs @@ -0,0 +1,54 @@ +-- | +-- Module : Crypto.Number.Serialize +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +-- Fast serialization primitives for integer +{-# LANGUAGE BangPatterns #-} +module Crypto.Number.Serialize + ( i2osp + , os2ip + , i2ospOf + , i2ospOf_ + ) where + +import Crypto.Number.Basic +import Crypto.Internal.Compat (unsafeDoIO) +import qualified Crypto.Internal.ByteArray as B +import qualified Crypto.Number.Serialize.Internal as Internal + +-- | @os2ip@ converts a byte string into a positive integer. +os2ip :: B.ByteArrayAccess ba => ba -> Integer +os2ip bs = unsafeDoIO $ B.withByteArray bs (\p -> Internal.os2ip p (B.length bs)) + +-- | @i2osp@ converts a positive integer into a byte string. +-- +-- The first byte is MSB (most significant byte); the last byte is the LSB (least significant byte) +i2osp :: B.ByteArray ba => Integer -> ba +i2osp 0 = B.allocAndFreeze 1 (\p -> Internal.i2osp 0 p 1 >> return ()) +i2osp m = B.allocAndFreeze sz (\p -> Internal.i2osp m p sz >> return ()) + where + !sz = numBytes m + +-- | Just like 'i2osp', but takes an extra parameter for size. +-- If the number is too big to fit in @len@ bytes, 'Nothing' is returned +-- otherwise the number is padded with 0 to fit the @len@ required. +{-# INLINABLE i2ospOf #-} +i2ospOf :: B.ByteArray ba => Int -> Integer -> Maybe ba +i2ospOf len m + | len <= 0 = Nothing + | m < 0 = Nothing + | sz > len = Nothing + | otherwise = Just $ B.unsafeCreate len (\p -> Internal.i2ospOf m p len >> return ()) + where + !sz = numBytes m + +-- | Just like 'i2ospOf' except that it doesn't expect a failure: i.e. +-- an integer larger than the number of output bytes requested. +-- +-- For example if you just took a modulo of the number that represent +-- the size (example the RSA modulo n). +i2ospOf_ :: B.ByteArray ba => Int -> Integer -> ba +i2ospOf_ len = maybe (error "i2ospOf_: integer is larger than expected") id . i2ospOf len diff --git a/bundled/Crypto/Number/Serialize/Internal.hs b/bundled/Crypto/Number/Serialize/Internal.hs new file mode 100644 index 0000000..bfa9622 --- /dev/null +++ b/bundled/Crypto/Number/Serialize/Internal.hs @@ -0,0 +1,76 @@ +-- | +-- Module : Crypto.Number.Serialize.Internal +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +-- Fast serialization primitives for integer using raw pointers +{-# LANGUAGE BangPatterns #-} +module Crypto.Number.Serialize.Internal + ( i2osp + , i2ospOf + , os2ip + ) where + +import Crypto.Number.Compat +import Crypto.Number.Basic +import Data.Bits +import Data.Memory.PtrMethods +import Data.Word (Word8) +import Foreign.Ptr +import Foreign.Storable + +-- | Fill a pointer with the big endian binary representation of an integer +-- +-- If the room available @ptrSz@ is less than the number of bytes needed, +-- 0 is returned. Likewise if a parameter is invalid, 0 is returned. +-- +-- Returns the number of bytes written +i2osp :: Integer -> Ptr Word8 -> Int -> IO Int +i2osp m ptr ptrSz + | ptrSz <= 0 = return 0 + | m < 0 = return 0 + | m == 0 = pokeByteOff ptr 0 (0 :: Word8) >> return 1 + | ptrSz < sz = return 0 + | otherwise = fillPtr ptr sz m >> return sz + where + !sz = numBytes m + +-- | Similar to 'i2osp', except it will pad any remaining space with zero. +i2ospOf :: Integer -> Ptr Word8 -> Int -> IO Int +i2ospOf m ptr ptrSz + | ptrSz <= 0 = return 0 + | m < 0 = return 0 + | ptrSz < sz = return 0 + | otherwise = do + memSet ptr 0 ptrSz + fillPtr (ptr `plusPtr` padSz) sz m + return ptrSz + where + !sz = numBytes m + !padSz = ptrSz - sz + +fillPtr :: Ptr Word8 -> Int -> Integer -> IO () +fillPtr p sz m = gmpExportInteger m p `onGmpUnsupported` export (sz-1) m + where + export ofs i + | ofs == 0 = pokeByteOff p ofs (fromIntegral i :: Word8) + | otherwise = do + let (i', b) = i `divMod` 256 + pokeByteOff p ofs (fromIntegral b :: Word8) + export (ofs-1) i' + +-- | Transform a big endian binary integer representation pointed by a pointer and a size +-- into an integer +os2ip :: Ptr Word8 -> Int -> IO Integer +os2ip ptr ptrSz + | ptrSz <= 0 = return 0 + | otherwise = gmpImportInteger ptrSz ptr `onGmpUnsupported` loop 0 0 ptr + where + loop :: Integer -> Int -> Ptr Word8 -> IO Integer + loop !acc i !p + | i == ptrSz = return acc + | otherwise = do + w <- peekByteOff p i :: IO Word8 + loop ((acc `shiftL` 8) .|. fromIntegral w) (i+1) p diff --git a/bundled/Crypto/Number/Serialize/Internal/LE.hs b/bundled/Crypto/Number/Serialize/Internal/LE.hs new file mode 100644 index 0000000..d4c2594 --- /dev/null +++ b/bundled/Crypto/Number/Serialize/Internal/LE.hs @@ -0,0 +1,75 @@ +-- | +-- Module : Crypto.Number.Serialize.Internal.LE +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +-- Fast serialization primitives for integer using raw pointers (little endian) +{-# LANGUAGE BangPatterns #-} +module Crypto.Number.Serialize.Internal.LE + ( i2osp + , i2ospOf + , os2ip + ) where + +import Crypto.Number.Compat +import Crypto.Number.Basic +import Data.Bits +import Data.Memory.PtrMethods +import Data.Word (Word8) +import Foreign.Ptr +import Foreign.Storable + +-- | Fill a pointer with the little endian binary representation of an integer +-- +-- If the room available @ptrSz@ is less than the number of bytes needed, +-- 0 is returned. Likewise if a parameter is invalid, 0 is returned. +-- +-- Returns the number of bytes written +i2osp :: Integer -> Ptr Word8 -> Int -> IO Int +i2osp m ptr ptrSz + | ptrSz <= 0 = return 0 + | m < 0 = return 0 + | m == 0 = pokeByteOff ptr 0 (0 :: Word8) >> return 1 + | ptrSz < sz = return 0 + | otherwise = fillPtr ptr sz m >> return sz + where + !sz = numBytes m + +-- | Similar to 'i2osp', except it will pad any remaining space with zero. +i2ospOf :: Integer -> Ptr Word8 -> Int -> IO Int +i2ospOf m ptr ptrSz + | ptrSz <= 0 = return 0 + | m < 0 = return 0 + | ptrSz < sz = return 0 + | otherwise = do + memSet ptr 0 ptrSz + fillPtr ptr sz m + return ptrSz + where + !sz = numBytes m + +fillPtr :: Ptr Word8 -> Int -> Integer -> IO () +fillPtr p sz m = gmpExportIntegerLE m p `onGmpUnsupported` export 0 m + where + export ofs i + | ofs >= sz = return () + | otherwise = do + let (i', b) = i `divMod` 256 + pokeByteOff p ofs (fromIntegral b :: Word8) + export (ofs+1) i' + +-- | Transform a little endian binary integer representation pointed by a +-- pointer and a size into an integer +os2ip :: Ptr Word8 -> Int -> IO Integer +os2ip ptr ptrSz + | ptrSz <= 0 = return 0 + | otherwise = gmpImportIntegerLE ptrSz ptr `onGmpUnsupported` loop 0 (ptrSz-1) ptr + where + loop :: Integer -> Int -> Ptr Word8 -> IO Integer + loop !acc i !p + | i < 0 = return acc + | otherwise = do + w <- peekByteOff p i :: IO Word8 + loop ((acc `shiftL` 8) .|. fromIntegral w) (i-1) p diff --git a/bundled/Crypto/Number/Serialize/LE.hs b/bundled/Crypto/Number/Serialize/LE.hs new file mode 100644 index 0000000..9f7fbae --- /dev/null +++ b/bundled/Crypto/Number/Serialize/LE.hs @@ -0,0 +1,54 @@ +-- | +-- Module : Crypto.Number.Serialize.LE +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +-- Fast serialization primitives for integer (little endian) +{-# LANGUAGE BangPatterns #-} +module Crypto.Number.Serialize.LE + ( i2osp + , os2ip + , i2ospOf + , i2ospOf_ + ) where + +import Crypto.Number.Basic +import Crypto.Internal.Compat (unsafeDoIO) +import qualified Crypto.Internal.ByteArray as B +import qualified Crypto.Number.Serialize.Internal.LE as Internal + +-- | @os2ip@ converts a byte string into a positive integer. +os2ip :: B.ByteArrayAccess ba => ba -> Integer +os2ip bs = unsafeDoIO $ B.withByteArray bs (\p -> Internal.os2ip p (B.length bs)) + +-- | @i2osp@ converts a positive integer into a byte string. +-- +-- The first byte is LSB (least significant byte); the last byte is the MSB (most significant byte) +i2osp :: B.ByteArray ba => Integer -> ba +i2osp 0 = B.allocAndFreeze 1 (\p -> Internal.i2osp 0 p 1 >> return ()) +i2osp m = B.allocAndFreeze sz (\p -> Internal.i2osp m p sz >> return ()) + where + !sz = numBytes m + +-- | Just like 'i2osp', but takes an extra parameter for size. +-- If the number is too big to fit in @len@ bytes, 'Nothing' is returned +-- otherwise the number is padded with 0 to fit the @len@ required. +{-# INLINABLE i2ospOf #-} +i2ospOf :: B.ByteArray ba => Int -> Integer -> Maybe ba +i2ospOf len m + | len <= 0 = Nothing + | m < 0 = Nothing + | sz > len = Nothing + | otherwise = Just $ B.unsafeCreate len (\p -> Internal.i2ospOf m p len >> return ()) + where + !sz = numBytes m + +-- | Just like 'i2ospOf' except that it doesn't expect a failure: i.e. +-- an integer larger than the number of output bytes requested. +-- +-- For example if you just took a modulo of the number that represent +-- the size (example the RSA modulo n). +i2ospOf_ :: B.ByteArray ba => Int -> Integer -> ba +i2ospOf_ len = maybe (error "i2ospOf_: integer is larger than expected") id . i2ospOf len diff --git a/bundled/Crypto/Random.hs b/bundled/Crypto/Random.hs new file mode 100644 index 0000000..28d99ef --- /dev/null +++ b/bundled/Crypto/Random.hs @@ -0,0 +1,98 @@ +-- | +-- Module : Crypto.Random +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : good +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Crypto.Random + ( + -- * Deterministic instances + ChaChaDRG + , SystemDRG + , Seed + -- * Seed + , seedNew + , seedFromInteger + , seedToInteger + , seedFromBinary + -- * Deterministic Random class + , getSystemDRG + , drgNew + , drgNewSeed + , drgNewTest + , withDRG + , withRandomBytes + , DRG(..) + -- * Random abstraction + , MonadRandom(..) + , MonadPseudoRandom + ) where + +import Crypto.Error +import Crypto.Random.Types +import Crypto.Random.ChaChaDRG +import Crypto.Random.SystemDRG +import Data.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes) +import qualified Data.ByteArray as B +import Crypto.Internal.Imports + +import qualified Crypto.Number.Serialize as Serialize + +newtype Seed = Seed ScrubbedBytes + deriving (ByteArrayAccess) + +-- Length for ChaCha DRG seed +seedLength :: Int +seedLength = 40 + +-- | Create a new Seed from system entropy +seedNew :: MonadRandom randomly => randomly Seed +seedNew = Seed `fmap` getRandomBytes seedLength + +-- | Convert a Seed to an integer +seedToInteger :: Seed -> Integer +seedToInteger (Seed b) = Serialize.os2ip b + +-- | Convert an integer to a Seed +seedFromInteger :: Integer -> Seed +seedFromInteger i = Seed $ Serialize.i2ospOf_ seedLength (i `mod` 2^(seedLength * 8)) + +-- | Convert a binary to a seed +seedFromBinary :: ByteArrayAccess b => b -> CryptoFailable Seed +seedFromBinary b + | B.length b /= 40 = CryptoFailed (CryptoError_SeedSizeInvalid) + | otherwise = CryptoPassed $ Seed $ B.convert b + +-- | Create a new DRG from system entropy +drgNew :: MonadRandom randomly => randomly ChaChaDRG +drgNew = drgNewSeed `fmap` seedNew + +-- | Create a new DRG from a seed +drgNewSeed :: Seed -> ChaChaDRG +drgNewSeed (Seed seed) = initialize seed + +-- | Create a new DRG from 5 Word64. +-- +-- This is a convenient interface to create deterministic interface +-- for quickcheck style testing. +-- +-- It can also be used in other contexts provided the input +-- has been properly randomly generated. +-- +-- Note that the @Arbitrary@ instance provided by QuickCheck for 'Word64' does +-- not have a uniform distribution. It is often better to use instead +-- @arbitraryBoundedRandom@. +-- +-- System endianness impacts how the tuple is interpreted and therefore changes +-- the resulting DRG. +drgNewTest :: (Word64, Word64, Word64, Word64, Word64) -> ChaChaDRG +drgNewTest = initializeWords + +-- | Generate @len random bytes and mapped the bytes to the function @f. +-- +-- This is equivalent to use Control.Arrow 'first' with 'randomBytesGenerate' +withRandomBytes :: (ByteArray ba, DRG g) => g -> Int -> (ba -> a) -> (a, g) +withRandomBytes rng len f = (f bs, rng') + where (bs, rng') = randomBytesGenerate len rng diff --git a/bundled/Crypto/Random/ChaChaDRG.hs b/bundled/Crypto/Random/ChaChaDRG.hs new file mode 100644 index 0000000..5062b59 --- /dev/null +++ b/bundled/Crypto/Random/ChaChaDRG.hs @@ -0,0 +1,46 @@ +-- | +-- Module : Crypto.Random.ChaChaDRG +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : good +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Crypto.Random.ChaChaDRG + ( ChaChaDRG + , initialize + , initializeWords + ) where + +import Crypto.Random.Types +import Crypto.Internal.Imports +import Crypto.Internal.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes) +import qualified Crypto.Internal.ByteArray as B +import Foreign.Storable (pokeElemOff) + +import qualified Crypto.Cipher.ChaCha as C + +instance DRG ChaChaDRG where + randomBytesGenerate = generate + +-- | ChaCha Deterministic Random Generator +newtype ChaChaDRG = ChaChaDRG C.StateSimple + deriving (NFData) + +-- | Initialize a new ChaCha context with the number of rounds, +-- the key and the nonce associated. +initialize :: ByteArrayAccess seed + => seed -- ^ 40 bytes of seed + -> ChaChaDRG -- ^ the initial ChaCha state +initialize seed = ChaChaDRG $ C.initializeSimple seed + +-- | Initialize a new ChaCha context from 5-tuple of words64. +-- This interface is useful when creating a RNG out of tests generators (e.g. QuickCheck). +initializeWords :: (Word64, Word64, Word64, Word64, Word64) -> ChaChaDRG +initializeWords (a,b,c,d,e) = initialize (B.allocAndFreeze 40 fill :: ScrubbedBytes) + where fill s = mapM_ (uncurry (pokeElemOff s)) [(0,a), (1,b), (2,c), (3,d), (4,e)] + +generate :: ByteArray output => Int -> ChaChaDRG -> (output, ChaChaDRG) +generate nbBytes st@(ChaChaDRG prevSt) + | nbBytes <= 0 = (B.empty, st) + | otherwise = let (output, newSt) = C.generateSimple prevSt nbBytes in (output, ChaChaDRG newSt) diff --git a/bundled/Crypto/Random/Entropy.hs b/bundled/Crypto/Random/Entropy.hs new file mode 100644 index 0000000..4746717 --- /dev/null +++ b/bundled/Crypto/Random/Entropy.hs @@ -0,0 +1,22 @@ +-- | +-- Module : Crypto.Random.Entropy +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +module Crypto.Random.Entropy + ( getEntropy + ) where + +import Data.Maybe (catMaybes) +import Crypto.Internal.ByteArray (ByteArray) +import qualified Crypto.Internal.ByteArray as B + +import Crypto.Random.Entropy.Unsafe + +-- | Get some entropy from the system source of entropy +getEntropy :: ByteArray byteArray => Int -> IO byteArray +getEntropy n = do + backends <- catMaybes `fmap` sequence supportedBackends + B.alloc n (replenish n backends) diff --git a/bundled/Crypto/Random/Entropy/Backend.hs b/bundled/Crypto/Random/Entropy/Backend.hs new file mode 100644 index 0000000..ca2acc2 --- /dev/null +++ b/bundled/Crypto/Random/Entropy/Backend.hs @@ -0,0 +1,57 @@ +-- | +-- Module : Crypto.Random.Entropy.Backend +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : good +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +module Crypto.Random.Entropy.Backend + ( EntropyBackend + , supportedBackends + , gatherBackend + ) where + +import Foreign.Ptr +import Data.Proxy +import Data.Word (Word8) +import Crypto.Random.Entropy.Source +#ifdef SUPPORT_RDRAND +import Crypto.Random.Entropy.RDRand +#endif +#ifdef WINDOWS +import Crypto.Random.Entropy.Windows +#else +import Crypto.Random.Entropy.Unix +#endif + +-- | All supported backends +supportedBackends :: [IO (Maybe EntropyBackend)] +supportedBackends = + [ +#ifdef SUPPORT_RDRAND + openBackend (Proxy :: Proxy RDRand), +#endif +#ifdef WINDOWS + openBackend (Proxy :: Proxy WinCryptoAPI) +#else + openBackend (Proxy :: Proxy DevRandom), openBackend (Proxy :: Proxy DevURandom) +#endif + ] + +-- | Any Entropy Backend +data EntropyBackend = forall b . EntropySource b => EntropyBackend b + +-- | Open a backend handle +openBackend :: EntropySource b => Proxy b -> IO (Maybe EntropyBackend) +openBackend b = fmap EntropyBackend `fmap` callOpen b + where callOpen :: EntropySource b => Proxy b -> IO (Maybe b) + callOpen _ = entropyOpen + +-- | Gather randomness from an open handle +gatherBackend :: EntropyBackend -- ^ An open Entropy Backend + -> Ptr Word8 -- ^ Pointer to a buffer to write to + -> Int -- ^ number of bytes to write + -> IO Int -- ^ return the number of bytes actually written +gatherBackend (EntropyBackend backend) ptr n = entropyGather backend ptr n diff --git a/bundled/Crypto/Random/Entropy/RDRand.hs b/bundled/Crypto/Random/Entropy/RDRand.hs new file mode 100644 index 0000000..275aac2 --- /dev/null +++ b/bundled/Crypto/Random/Entropy/RDRand.hs @@ -0,0 +1,38 @@ +-- | +-- Module : Crypto.Random.Entropy.RDRand +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +{-# LANGUAGE ForeignFunctionInterface #-} +module Crypto.Random.Entropy.RDRand + ( RDRand + ) where + +import Foreign.Ptr +import Foreign.C.Types +import Data.Word (Word8) +import Crypto.Random.Entropy.Source + +foreign import ccall unsafe "cryptonite_cpu_has_rdrand" + c_cpu_has_rdrand :: IO CInt + +foreign import ccall unsafe "cryptonite_get_rand_bytes" + c_get_rand_bytes :: Ptr Word8 -> CInt -> IO CInt + +-- | Fake handle to Intel RDRand entropy CPU instruction +data RDRand = RDRand + +instance EntropySource RDRand where + entropyOpen = rdrandGrab + entropyGather _ = rdrandGetBytes + entropyClose _ = return () + +rdrandGrab :: IO (Maybe RDRand) +rdrandGrab = supported `fmap` c_cpu_has_rdrand + where supported 0 = Nothing + supported _ = Just RDRand + +rdrandGetBytes :: Ptr Word8 -> Int -> IO Int +rdrandGetBytes ptr sz = fromIntegral `fmap` c_get_rand_bytes ptr (fromIntegral sz) diff --git a/bundled/Crypto/Random/Entropy/Source.hs b/bundled/Crypto/Random/Entropy/Source.hs new file mode 100644 index 0000000..cb76ab8 --- /dev/null +++ b/bundled/Crypto/Random/Entropy/Source.hs @@ -0,0 +1,22 @@ +-- | +-- Module : Crypto.Random.Entropy.Source +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +module Crypto.Random.Entropy.Source where + +import Foreign.Ptr +import Data.Word (Word8) + +-- | A handle to an entropy maker, either a system capability +-- or a hardware generator. +class EntropySource a where + -- | Try to open an handle for this source + entropyOpen :: IO (Maybe a) + -- | Try to gather a number of entropy bytes into a buffer. + -- Return the number of actual bytes gathered + entropyGather :: a -> Ptr Word8 -> Int -> IO Int + -- | Close an open handle + entropyClose :: a -> IO () diff --git a/bundled/Crypto/Random/Entropy/Unix.hs b/bundled/Crypto/Random/Entropy/Unix.hs new file mode 100644 index 0000000..a8aae43 --- /dev/null +++ b/bundled/Crypto/Random/Entropy/Unix.hs @@ -0,0 +1,74 @@ +-- | +-- Module : Crypto.Random.Entropy.Unix +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +{-# LANGUAGE ScopedTypeVariables #-} +module Crypto.Random.Entropy.Unix + ( DevRandom + , DevURandom + ) where + +import Foreign.Ptr +import Data.Word (Word8) +import Crypto.Random.Entropy.Source +import Control.Exception as E + +--import System.Posix.Types (Fd) +import System.IO + +type H = Handle +type DeviceName = String + +-- | Entropy device @/dev/random@ on unix system +newtype DevRandom = DevRandom DeviceName + +-- | Entropy device @/dev/urandom@ on unix system +newtype DevURandom = DevURandom DeviceName + +instance EntropySource DevRandom where + entropyOpen = fmap DevRandom `fmap` testOpen "/dev/random" + entropyGather (DevRandom name) ptr n = + withDev name $ \h -> gatherDevEntropyNonBlock h ptr n + entropyClose (DevRandom _) = return () + +instance EntropySource DevURandom where + entropyOpen = fmap DevURandom `fmap` testOpen "/dev/urandom" + entropyGather (DevURandom name) ptr n = + withDev name $ \h -> gatherDevEntropy h ptr n + entropyClose (DevURandom _) = return () + +testOpen :: DeviceName -> IO (Maybe DeviceName) +testOpen filepath = do + d <- openDev filepath + case d of + Nothing -> return Nothing + Just h -> closeDev h >> return (Just filepath) + +openDev :: String -> IO (Maybe H) +openDev filepath = (Just `fmap` openAndNoBuffering) `E.catch` \(_ :: IOException) -> return Nothing + where openAndNoBuffering = do + h <- openBinaryFile filepath ReadMode + hSetBuffering h NoBuffering + return h + +withDev :: String -> (H -> IO a) -> IO a +withDev filepath f = openDev filepath >>= \h -> + case h of + Nothing -> error ("device " ++ filepath ++ " cannot be grabbed") + Just fd -> f fd `E.finally` closeDev fd + +closeDev :: H -> IO () +closeDev h = hClose h + +gatherDevEntropy :: H -> Ptr Word8 -> Int -> IO Int +gatherDevEntropy h ptr sz = + (fromIntegral `fmap` hGetBufSome h ptr (fromIntegral sz)) + `E.catch` \(_ :: IOException) -> return 0 + +gatherDevEntropyNonBlock :: H -> Ptr Word8 -> Int -> IO Int +gatherDevEntropyNonBlock h ptr sz = + (fromIntegral `fmap` hGetBufNonBlocking h ptr (fromIntegral sz)) + `E.catch` \(_ :: IOException) -> return 0 diff --git a/bundled/Crypto/Random/Entropy/Unsafe.hs b/bundled/Crypto/Random/Entropy/Unsafe.hs new file mode 100644 index 0000000..672e9c2 --- /dev/null +++ b/bundled/Crypto/Random/Entropy/Unsafe.hs @@ -0,0 +1,34 @@ +-- | +-- Module : Crypto.Random.Entropy.Unsafe +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +module Crypto.Random.Entropy.Unsafe + ( replenish + , module Crypto.Random.Entropy.Backend + ) where + +import Data.Word (Word8) +import Foreign.Ptr (Ptr, plusPtr) +import Crypto.Random.Entropy.Backend + +-- | Refill the entropy in a buffer +-- +-- Call each entropy backend in turn until the buffer has +-- been replenished. +-- +-- If the buffer cannot be refill after 3 loopings, this will raise +-- an User Error exception +replenish :: Int -> [EntropyBackend] -> Ptr Word8 -> IO () +replenish _ [] _ = fail "cryptonite: random: cannot get any source of entropy on this system" +replenish poolSize backends ptr = loop 0 backends ptr poolSize + where loop :: Int -> [EntropyBackend] -> Ptr Word8 -> Int -> IO () + loop retry [] p n | n == 0 = return () + | retry == 3 = error "cryptonite: random: cannot fully replenish" + | otherwise = loop (retry+1) backends p n + loop _ (_:_) _ 0 = return () + loop retry (b:bs) p n = do + r <- gatherBackend b p n + loop retry bs (p `plusPtr` r) (n - r) diff --git a/bundled/Crypto/Random/Entropy/Windows.hs b/bundled/Crypto/Random/Entropy/Windows.hs new file mode 100644 index 0000000..1fbad39 --- /dev/null +++ b/bundled/Crypto/Random/Entropy/Windows.hs @@ -0,0 +1,103 @@ +-- | +-- Module : Crypto.Random.Entropy.Windows +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +-- Code originally from the entropy package and thus is: +-- Copyright (c) Thomas DuBuisson. +-- +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} +module Crypto.Random.Entropy.Windows + ( WinCryptoAPI + ) where + +import Data.Int (Int32) +import Data.Word +import Foreign.C.String (CString, withCString) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Utils (toBool) +import Foreign.Storable (peek) +import System.Win32.Types (getLastError) + +import Crypto.Random.Entropy.Source + + +-- | Handle to Windows crypto API for random generation +data WinCryptoAPI = WinCryptoAPI + +instance EntropySource WinCryptoAPI where + entropyOpen = do + mctx <- cryptAcquireCtx + maybe (return Nothing) (\ctx -> cryptReleaseCtx ctx >> return (Just WinCryptoAPI)) mctx + entropyGather WinCryptoAPI ptr n = do + mctx <- cryptAcquireCtx + case mctx of + Nothing -> do + lastError <- getLastError + fail $ "cannot re-grab win crypto api: error " ++ show lastError + Just ctx -> do + r <- cryptGenRandom ctx ptr n + cryptReleaseCtx ctx + return r + entropyClose WinCryptoAPI = return () + + +type DWORD = Word32 +type BOOL = Int32 +type BYTE = Word8 + +#if defined(ARCH_X86) +# define WINDOWS_CCONV stdcall +type CryptCtx = Word32 +#elif defined(ARCH_X86_64) +# define WINDOWS_CCONV ccall +type CryptCtx = Word64 +#else +# error Unknown mingw32 arch +#endif + +-- Declare the required CryptoAPI imports +foreign import WINDOWS_CCONV unsafe "CryptAcquireContextA" + c_cryptAcquireCtx :: Ptr CryptCtx -> CString -> CString -> DWORD -> DWORD -> IO BOOL +foreign import WINDOWS_CCONV unsafe "CryptGenRandom" + c_cryptGenRandom :: CryptCtx -> DWORD -> Ptr BYTE -> IO BOOL +foreign import WINDOWS_CCONV unsafe "CryptReleaseContext" + c_cryptReleaseCtx :: CryptCtx -> DWORD -> IO BOOL + + +-- Define the constants we need from WinCrypt.h +msDefProv :: String +msDefProv = "Microsoft Base Cryptographic Provider v1.0" + +provRSAFull :: DWORD +provRSAFull = 1 + +cryptVerifyContext :: DWORD +cryptVerifyContext = 0xF0000000 + +cryptAcquireCtx :: IO (Maybe CryptCtx) +cryptAcquireCtx = + alloca $ \handlePtr -> + withCString msDefProv $ \provName -> do + r <- toBool `fmap` c_cryptAcquireCtx handlePtr nullPtr provName provRSAFull cryptVerifyContext + if r + then Just `fmap` peek handlePtr + else return Nothing + +cryptGenRandom :: CryptCtx -> Ptr Word8 -> Int -> IO Int +cryptGenRandom h buf n = do + success <- toBool `fmap` c_cryptGenRandom h (fromIntegral n) buf + return $ if success then n else 0 + +cryptReleaseCtx :: CryptCtx -> IO () +cryptReleaseCtx h = do + success <- toBool `fmap` c_cryptReleaseCtx h 0 + if success + then return () + else do + lastError <- getLastError + fail $ "cryptReleaseCtx: error " ++ show lastError diff --git a/bundled/Crypto/Random/EntropyPool.hs b/bundled/Crypto/Random/EntropyPool.hs new file mode 100644 index 0000000..a46bf7b --- /dev/null +++ b/bundled/Crypto/Random/EntropyPool.hs @@ -0,0 +1,71 @@ +-- | +-- Module : Crypto.Random.EntropyPool +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +module Crypto.Random.EntropyPool + ( EntropyPool + , createEntropyPool + , createEntropyPoolWith + , getEntropyFrom + ) where + +import Control.Concurrent.MVar +import Crypto.Random.Entropy.Unsafe +import Crypto.Internal.ByteArray (ByteArray, ScrubbedBytes) +import qualified Crypto.Internal.ByteArray as B +import Data.Word (Word8) +import Data.Maybe (catMaybes) +import Foreign.Marshal.Utils (copyBytes) +import Foreign.Ptr (plusPtr, Ptr) + +-- | Pool of Entropy. Contains a self-mutating pool of entropy, +-- that is always guaranteed to contain data. +data EntropyPool = EntropyPool [EntropyBackend] (MVar Int) ScrubbedBytes + +-- size of entropy pool by default +defaultPoolSize :: Int +defaultPoolSize = 4096 + +-- | Create a new entropy pool of a specific size +-- +-- While you can create as many entropy pools as you want, +-- the pool can be shared between multiples RNGs. +createEntropyPoolWith :: Int -> [EntropyBackend] -> IO EntropyPool +createEntropyPoolWith poolSize backends = do + m <- newMVar 0 + sm <- B.alloc poolSize (replenish poolSize backends) + return $ EntropyPool backends m sm + +-- | Create a new entropy pool with a default size. +-- +-- While you can create as many entropy pools as you want, +-- the pool can be shared between multiples RNGs. +createEntropyPool :: IO EntropyPool +createEntropyPool = do + backends <- catMaybes `fmap` sequence supportedBackends + createEntropyPoolWith defaultPoolSize backends + +-- | Put a chunk of the entropy pool into a buffer +getEntropyPtr :: EntropyPool -> Int -> Ptr Word8 -> IO () +getEntropyPtr (EntropyPool backends posM sm) n outPtr = + B.withByteArray sm $ \entropyPoolPtr -> + modifyMVar_ posM $ \pos -> + copyLoop outPtr entropyPoolPtr pos n + where poolSize = B.length sm + copyLoop d s pos left + | left == 0 = return pos + | otherwise = do + wrappedPos <- + if pos == poolSize + then replenish poolSize backends s >> return 0 + else return pos + let m = min (poolSize - wrappedPos) left + copyBytes d (s `plusPtr` wrappedPos) m + copyLoop (d `plusPtr` m) s (wrappedPos + m) (left - m) + +-- | Grab a chunk of entropy from the entropy pool. +getEntropyFrom :: ByteArray byteArray => EntropyPool -> Int -> IO byteArray +getEntropyFrom pool n = B.alloc n (getEntropyPtr pool n) diff --git a/bundled/Crypto/Random/Probabilistic.hs b/bundled/Crypto/Random/Probabilistic.hs new file mode 100644 index 0000000..176427f --- /dev/null +++ b/bundled/Crypto/Random/Probabilistic.hs @@ -0,0 +1,28 @@ +-- | +-- Module : Crypto.Random.Probabilistic +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +module Crypto.Random.Probabilistic + ( probabilistic + ) where + +import Crypto.Internal.Compat +import Crypto.Random.Types +import Crypto.Random + +-- | This create a random number generator out of thin air with +-- the system entropy; don't generally use as the IO is not exposed +-- this can have unexpected random for. +-- +-- This is useful for probabilistic algorithm like Miller Rabin +-- probably prime algorithm, given appropriate choice of the heuristic +-- +-- Generally, it's advised not to use this function. +probabilistic :: MonadPseudoRandom ChaChaDRG a -> a +probabilistic f = fst $ withDRG drg f + where {-# NOINLINE drg #-} + drg = unsafeDoIO drgNew +{-# NOINLINE probabilistic #-} diff --git a/bundled/Crypto/Random/SystemDRG.hs b/bundled/Crypto/Random/SystemDRG.hs new file mode 100644 index 0000000..4f401ca --- /dev/null +++ b/bundled/Crypto/Random/SystemDRG.hs @@ -0,0 +1,63 @@ +-- | +-- Module : Crypto.Random.SystemDRG +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +{-# LANGUAGE BangPatterns #-} +module Crypto.Random.SystemDRG + ( SystemDRG + , getSystemDRG + ) where + +import Crypto.Random.Types +import Crypto.Random.Entropy.Unsafe +import Crypto.Internal.Compat +import Data.ByteArray (ScrubbedBytes, ByteArray) +import Data.Memory.PtrMethods as B (memCopy) +import Data.Maybe (catMaybes) +import Data.Tuple (swap) +import Foreign.Ptr +import qualified Data.ByteArray as B +import System.IO.Unsafe (unsafeInterleaveIO) + +-- | A referentially transparent System representation of +-- the random evaluated out of the system. +-- +-- Holding onto a specific DRG means that all the already +-- evaluated bytes will be consistently replayed. +-- +-- There's no need to reseed this DRG, as only pure +-- entropy is represented here. +data SystemDRG = SystemDRG !Int [ScrubbedBytes] + +instance DRG SystemDRG where + randomBytesGenerate = generate + +systemChunkSize :: Int +systemChunkSize = 256 + +-- | Grab one instance of the System DRG +getSystemDRG :: IO SystemDRG +getSystemDRG = do + backends <- catMaybes `fmap` sequence supportedBackends + let getNext = unsafeInterleaveIO $ do + bs <- B.alloc systemChunkSize (replenish systemChunkSize backends) + more <- getNext + return (bs:more) + SystemDRG 0 <$> getNext + +generate :: ByteArray output => Int -> SystemDRG -> (output, SystemDRG) +generate nbBytes (SystemDRG ofs sysChunks) = swap $ unsafeDoIO $ B.allocRet nbBytes $ loop ofs sysChunks nbBytes + where loop currentOfs chunks 0 _ = return $! SystemDRG currentOfs chunks + loop _ [] _ _ = error "SystemDRG: the impossible happened: empty chunk" + loop currentOfs oChunks@(c:cs) n d = do + let currentLeft = B.length c - currentOfs + toCopy = min n currentLeft + nextOfs = currentOfs + toCopy + n' = n - toCopy + B.withByteArray c $ \src -> B.memCopy d (src `plusPtr` currentOfs) toCopy + if nextOfs == B.length c + then loop 0 cs n' (d `plusPtr` toCopy) + else loop nextOfs oChunks n' (d `plusPtr` toCopy) diff --git a/bundled/Crypto/Random/Types.hs b/bundled/Crypto/Random/Types.hs new file mode 100644 index 0000000..c82489f --- /dev/null +++ b/bundled/Crypto/Random/Types.hs @@ -0,0 +1,60 @@ +-- | +-- Module : Crypto.Random.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +module Crypto.Random.Types + ( + MonadRandom(..) + , MonadPseudoRandom + , DRG(..) + , withDRG + ) where + +import Crypto.Random.Entropy +import Crypto.Internal.ByteArray + +-- | A monad constraint that allows to generate random bytes +class Monad m => MonadRandom m where + getRandomBytes :: ByteArray byteArray => Int -> m byteArray + +-- | A Deterministic Random Generator (DRG) class +class DRG gen where + -- | Generate N bytes of randomness from a DRG + randomBytesGenerate :: ByteArray byteArray => Int -> gen -> (byteArray, gen) + +instance MonadRandom IO where + getRandomBytes = getEntropy + +-- | A simple Monad class very similar to a State Monad +-- with the state being a DRG. +newtype MonadPseudoRandom gen a = MonadPseudoRandom + { runPseudoRandom :: gen -> (a, gen) + } + +instance DRG gen => Functor (MonadPseudoRandom gen) where + fmap f m = MonadPseudoRandom $ \g1 -> + let (a, g2) = runPseudoRandom m g1 in (f a, g2) + +instance DRG gen => Applicative (MonadPseudoRandom gen) where + pure a = MonadPseudoRandom $ \g -> (a, g) + (<*>) fm m = MonadPseudoRandom $ \g1 -> + let (f, g2) = runPseudoRandom fm g1 + (a, g3) = runPseudoRandom m g2 + in (f a, g3) + +instance DRG gen => Monad (MonadPseudoRandom gen) where + return = pure + (>>=) m1 m2 = MonadPseudoRandom $ \g1 -> + let (a, g2) = runPseudoRandom m1 g1 + in runPseudoRandom (m2 a) g2 + +instance DRG gen => MonadRandom (MonadPseudoRandom gen) where + getRandomBytes n = MonadPseudoRandom (randomBytesGenerate n) + +-- | Run a pure computation with a Deterministic Random Generator +-- in the 'MonadPseudoRandom' +withDRG :: DRG gen => gen -> MonadPseudoRandom gen a -> (a, gen) +withDRG gen m = runPseudoRandom m gen diff --git a/bundled/Crypto/Sign/Ed25519.hs b/bundled/Crypto/Sign/Ed25519.hs new file mode 100644 index 0000000..1b45a40 --- /dev/null +++ b/bundled/Crypto/Sign/Ed25519.hs @@ -0,0 +1,819 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +#endif + +-- | +-- Module : Crypto.Sign.Ed25519 +-- Copyright : (c) Austin Seipp 2013-2015 +-- License : MIT +-- +-- Maintainer : aseipp@pobox.com +-- Stability : experimental +-- Portability : portable +-- +-- This module provides bindings to the Ed25519 public-key signature +-- system, including detached signatures. The documentation should be +-- self explanatory with complete examples. +-- +-- Below the basic documentation you'll find API, performance and +-- security notes, which you may want to read carefully before +-- continuing. (Nonetheless, @Ed25519@ is one of the easiest-to-use +-- signature systems around, and is simple to get started with for +-- building more complex protocols. But the below details are highly +-- educational and should help adjust your expectations properly.) +-- +-- For more reading on the underlying implementation and theory +-- (including how to get a copy of the Ed25519 software), +-- visit . There are two papers that discuss +-- the design of EdDSA/Ed25519 in detail: +-- +-- * - +-- The original specification by Bernstein, Duif, Lange, Schwabe, +-- and Yang. +-- +-- * - +-- An extension of the original EdDSA specification allowing it to +-- be used with more curves (such as Ed41417, or Ed488), as well as +-- defining the support for __message prehashing__. The original +-- EdDSA is easily derived from the extended version through a few +-- parameter defaults. (This package won't consider non-Ed25519 +-- EdDSA systems any further.) +-- +module Crypto.Sign.Ed25519 + ( -- * A crash course introduction + -- $intro + + -- * Keypair creation + -- $creatingkeys + PublicKey(..) -- :: * + , SecretKey(..) -- :: * + , createKeypair -- :: IO (PublicKey, SecretKey) + , createKeypairFromSeed_ -- :: ByteString -> Maybe (PublicKey, SecretKey) + , createKeypairFromSeed -- :: ByteString -> (PublicKey, SecretKey) + , toPublicKey -- :: SecretKey -> PublicKey + + -- * Signing and verifying messages + -- $signatures + , sign -- :: SecretKey -> ByteString -> ByteString + , verify -- :: PublicKey -> ByteString -> Bool + + -- * Detached signatures + -- $detachedsigs + , Signature(..) -- :: * + , dsign -- :: SecretKey -> ByteString -> Signature + , dverify -- :: PublicKey -> ByteString -> Signature -> Bool + -- ** Deprecated interface + -- | The below interface is deprecated but functionally + -- equivalent to the above; it simply has \"worse\" naming and will + -- eventually be removed. + , sign' -- :: SecretKey -> ByteString -> Signature + , verify' -- :: PublicKey -> ByteString -> Signature -> Bool + + -- * Security, design and implementation notes + -- $security + + -- ** EdDSA background and properties + -- $background + + -- *** Generation of psuedo-random seeds + -- $seedgen + + -- ** Performance and implementation + -- $performance + + -- ** Secure @'SecretKey'@ storage + -- $keystorage + + -- ** Prehashing and large input messages + -- $prehashing + ) where +import Foreign.C.Types +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Ptr +import Foreign.Storable + +import System.IO.Unsafe (unsafePerformIO) + +import Data.Maybe (fromMaybe) + +import Data.ByteString as S +import Data.ByteString.Internal as SI +import Data.ByteString.Unsafe as SU +import Data.Word + +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics (Generic) +#endif + +-- Doctest setup with some examples + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.ByteString.Char8 +-- >>> let hash x = x +-- >>> let readBigFile x = return x + +-------------------------------------------------------------------------------- +-- Key creation + +-- $creatingkeys +-- +-- Ed25519 signatures start off life by having a keypair created, +-- using @'createKeypair'@ or @'createKeypairFromSeed_'@, which gives +-- you back a @'SecretKey'@ you can use for signing messages, and a +-- @'PublicKey'@ your users can use to verify you in fact authored the +-- messages. +-- +-- Ed25519 is a /deterministic signature system/, meaning that you may +-- always recompute a @'PublicKey'@ and a @'SecretKey'@ from an +-- initial, 32-byte input seed. Despite that, the default interface +-- almost all clients will wish to use is simply @'createKeypair'@, +-- which uses an Operating System provided source of secure randomness +-- to seed key creation. (For more information, see the security notes +-- at the bottom of this page.) + +-- | A @'PublicKey'@ created by @'createKeypair'@. +-- +-- @since 0.0.1.0 +newtype PublicKey = PublicKey { unPublicKey :: ByteString + -- ^ Unwrapper for getting the raw + -- @'ByteString'@ in a + -- @'PublicKey'@. In general you + -- should not make any assumptions + -- about the underlying blob; this is + -- only provided for interoperability. + } + deriving (Eq, Show, Ord) + +-- | A @'SecretKey'@ created by @'createKeypair'@. __Be sure to keep this__ +-- __safe!__ +-- +-- @since 0.0.1.0 +newtype SecretKey = SecretKey { unSecretKey :: ByteString + -- ^ Unwrapper for getting the raw + -- @'ByteString'@ in a + -- @'SecretKey'@. In general you + -- should not make any assumptions + -- about the underlying blob; this is + -- only provided for interoperability. + } + deriving (Eq, Show, Ord) + +#if __GLASGOW_HASKELL__ >= 702 +deriving instance Generic PublicKey +deriving instance Generic SecretKey +#endif + +-- | Randomly generate a @'SecretKey'@ and @'PublicKey'@ for doing +-- authenticated signing and verification. This essentically calls +-- @'createKeypairFromSeed_'@ with a randomly generated 32-byte seed, +-- the source of which is operating-system dependent (see security +-- notes below). However, internally it is implemented more +-- efficiently (with less allocations and copies). +-- +-- If you wish to use your own seed (for design purposes so you may +-- recreate keys, due to high paranoia, or because you have your own +-- source of randomness), please use @'createKeypairFromSeed_'@ +-- instead. +-- +-- @since 0.0.1.0 +createKeypair :: IO (PublicKey, SecretKey) +createKeypair = do + pk <- SI.mallocByteString cryptoSignPUBLICKEYBYTES + sk <- SI.mallocByteString cryptoSignSECRETKEYBYTES + + _ <- withForeignPtr pk $ \ppk -> do + _ <- withForeignPtr sk $ \psk -> do + _ <- c_crypto_sign_keypair ppk psk + return () + return () + + return (PublicKey $ SI.fromForeignPtr pk 0 cryptoSignPUBLICKEYBYTES, + SecretKey $ SI.fromForeignPtr sk 0 cryptoSignSECRETKEYBYTES) + +-- | Generate a deterministic @'PublicKey'@ and @'SecretKey'@ from a +-- given 32-byte seed, allowing you to recreate a keypair at any point +-- in time, providing you have the seed available. +-- +-- If the input seed is not 32 bytes in length, +-- @'createKeypairFromSeed_'@ returns @'Nothing'@. Otherwise, it +-- always returns @'Just' (pk, sk)@ for the given seed. +-- +-- __/NOTE/__: This function will replace @'createKeypairFromSeed'@ in +-- the future. +-- +-- @since 0.0.4.0 +createKeypairFromSeed_ :: ByteString -- ^ 32-byte seed + -> Maybe (PublicKey, SecretKey) -- ^ Resulting keypair +createKeypairFromSeed_ seed + | S.length seed /= cryptoSignSEEDBYTES = Nothing + | otherwise = unsafePerformIO $ do + pk <- SI.mallocByteString cryptoSignPUBLICKEYBYTES + sk <- SI.mallocByteString cryptoSignSECRETKEYBYTES + + _ <- SU.unsafeUseAsCString seed $ \pseed -> do + _ <- withForeignPtr pk $ \ppk -> do + _ <- withForeignPtr sk $ \psk -> do + _ <- c_crypto_sign_seed_keypair ppk psk pseed + return () + return () + return () + + return $ Just (PublicKey $ SI.fromForeignPtr pk 0 cryptoSignPUBLICKEYBYTES, + SecretKey $ SI.fromForeignPtr sk 0 cryptoSignSECRETKEYBYTES) + +-- | Generate a deterministic @'PublicKey'@ and @'SecretKey'@ from a +-- given 32-byte seed, allowing you to recreate a keypair at any point +-- in time, providing you have the seed available. +-- +-- Note that this will @'error'@ if the given input is not 32 bytes in +-- length, so you must be careful with this input. +-- +-- @since 0.0.3.0 +createKeypairFromSeed :: ByteString -- ^ 32-byte seed + -> (PublicKey, SecretKey) -- ^ Resulting keypair +createKeypairFromSeed seed + = fromMaybe (error "seed has incorrect length") (createKeypairFromSeed_ seed) +{-# DEPRECATED createKeypairFromSeed "This function is unsafe as it can @'fail'@ with an invalid input. Use @'createKeypairWithSeed_'@ instead." #-} + +-- | Derive the @'PublicKey'@ for a given @'SecretKey'@. This is a +-- convenience which allows (for example) using @'createKeypair'@ and +-- only ever storing the returned @'SecretKey'@ for any future +-- operations. +-- +-- @since 0.0.3.0 +toPublicKey :: SecretKey -- ^ Any valid @'SecretKey'@ + -> PublicKey -- ^ Corresponding @'PublicKey'@ +toPublicKey = PublicKey . S.drop prefixBytes . unSecretKey + where prefixBytes = cryptoSignSECRETKEYBYTES - cryptoSignPUBLICKEYBYTES + +-------------------------------------------------------------------------------- +-- Default, non-detached API + +-- $signatures +-- +-- By default, the Ed25519 interface computes a /signed message/ given +-- a @'SecretKey'@ and an input message. A /signed message/ consists +-- of an Ed25519 signature (of unspecified format), followed by the +-- input message. This means that given an input message of @M@ +-- bytes, you get back a message of @M+N@ bytes where @N@ is a +-- constant (the size of the Ed25519 signature blob). +-- +-- The default interface in this package reflects that. As a result, +-- any time you use @'sign'@ or @'verify'@ you will be given back the +-- full input, and then some. +-- + +-- | Sign a message with a particular @'SecretKey'@. Note that the resulting +-- signed message contains both the message itself, and the signature +-- attached. If you only want the signature of a given input string, +-- please see @'dsign'@. +-- +-- @since 0.0.1.0 +sign :: SecretKey + -- ^ Signers @'SecretKey'@ + -> ByteString + -- ^ Input message + -> ByteString + -- ^ Resulting signed message +sign (SecretKey sk) xs = + unsafePerformIO . SU.unsafeUseAsCStringLen xs $ \(mstr,mlen) -> + SU.unsafeUseAsCString sk $ \psk -> + SI.createAndTrim (mlen+cryptoSignBYTES) $ \out -> + alloca $ \smlen -> do + _ <- c_crypto_sign out smlen mstr (fromIntegral mlen) psk + fromIntegral `fmap` peek smlen +{-# INLINE sign #-} + +-- | Verifies a signed message against a @'PublicKey'@. Note that the input +-- message must be generated by @'sign'@ (that is, it is the message +-- itself plus its signature). If you want to verify an arbitrary +-- signature against an arbitrary message, please see @'dverify'@. +-- +-- @since 0.0.1.0 +verify :: PublicKey + -- ^ Signers @'PublicKey'@ + -> ByteString + -- ^ Signed message + -> Bool + -- ^ Verification result +verify (PublicKey pk) xs = + unsafePerformIO . SU.unsafeUseAsCStringLen xs $ \(smstr,smlen) -> + SU.unsafeUseAsCString pk $ \ppk -> + alloca $ \pmlen -> do + out <- SI.mallocByteString smlen + r <- withForeignPtr out $ \pout -> + c_crypto_sign_open pout pmlen smstr (fromIntegral smlen) ppk + + return (r == 0) +{-# INLINE verify #-} + +-------------------------------------------------------------------------------- +-- Detached signature support + +-- $detachedsigs +-- +-- This package also provides an alternative interface for /detached/ +-- /signatures/, which is more in-line with what you might +-- traditionally expect from a signing API. In this mode, the +-- @'dsign'@ and @'dverify'@ interfaces simply return a constant-sized +-- blob, representing the Ed25519 signature of the input message. +-- +-- This allows users to independently download, verify or attach +-- signatures to messages in any way they see fit - for example, by +-- providing a tarball file to download, with a corresponding @.sig@ +-- file containing the Ed25519 signature from the author. + +-- | A @'Signature'@ which is detached from the message it signed. +-- +-- @since 0.0.1.0 +newtype Signature = Signature { unSignature :: ByteString + -- ^ Unwrapper for getting the raw + -- @'ByteString'@ in a + -- @'Signature'@. In general you + -- should not make any assumptions + -- about the underlying blob; this is + -- only provided for interoperability. + } + deriving (Eq, Show, Ord) + +#if __GLASGOW_HASKELL__ >= 702 +deriving instance Generic Signature +#endif + +-- | Sign a message with a particular @'SecretKey'@, only returning the +-- @'Signature'@ without the message. +-- +-- @since 0.0.4.0 +dsign :: SecretKey + -- ^ Signers @'SecretKey'@ + -> ByteString + -- ^ Input message + -> Signature + -- ^ Message @'Signature'@, without the message +dsign sk xs = + let sm = sign sk xs + l = S.length sm + in Signature $! S.take (l - S.length xs) sm +{-# INLINE dsign #-} + +-- | Verify a message with a detached @'Signature'@ against a given +-- @'PublicKey'@. +-- +-- @since 0.0.4.0 +dverify :: PublicKey + -- ^ Signers @'PublicKey'@ + -> ByteString + -- ^ Raw input message + -> Signature + -- ^ Message @'Signature'@ + -> Bool + -- ^ Verification result +dverify pk xs (Signature sig) = verify pk (sig `S.append` xs) +{-# INLINE dverify #-} + +-- | Sign a message with a particular @'SecretKey'@, only returning the +-- @'Signature'@ without the message. Simply an alias for @'dsign'@. +-- +-- @since 0.0.1.0 +sign' :: SecretKey + -- ^ Signers @'SecretKey'@ + -> ByteString + -- ^ Input message + -> Signature + -- ^ Message @'Signature'@, without the message +sign' sk xs = dsign sk xs +{-# DEPRECATED sign' "@'sign''@ will be removed in a future release; use @'dsign'@ instead." #-} + +-- | Verify a message with a detached @'Signature'@ against a given +-- @'PublicKey'@. Simply an alias for @'dverify'@. +-- +-- @since 0.0.1.0 +verify' :: PublicKey + -- ^ Signers @'PublicKey'@ + -> ByteString + -- ^ Raw input message + -> Signature + -- ^ Message @'Signature'@ + -> Bool + -- ^ Verification result +verify' pk xs sig = dverify pk xs sig +{-# DEPRECATED verify' "@'verify''@ will be removed in a future release; use @'dverify'@ instead." #-} + +-------------------------------------------------------------------------------- +-- FFI binding + +cryptoSignSECRETKEYBYTES :: Int +cryptoSignSECRETKEYBYTES = 64 + +cryptoSignPUBLICKEYBYTES :: Int +cryptoSignPUBLICKEYBYTES = 32 + +cryptoSignBYTES :: Int +cryptoSignBYTES = 64 + +cryptoSignSEEDBYTES :: Int +cryptoSignSEEDBYTES = 32 + +foreign import ccall unsafe "ed25519_sign_seed_keypair" + c_crypto_sign_seed_keypair :: Ptr Word8 -> Ptr Word8 + -> Ptr CChar -> IO CInt + +foreign import ccall unsafe "ed25519_sign_keypair" + c_crypto_sign_keypair :: Ptr Word8 -> Ptr Word8 -> IO CInt + +foreign import ccall unsafe "ed25519_sign" + c_crypto_sign :: Ptr Word8 -> Ptr CULLong -> + Ptr CChar -> CULLong -> Ptr CChar -> IO CULLong + +foreign import ccall unsafe "ed25519_sign_open" + c_crypto_sign_open :: Ptr Word8 -> Ptr CULLong -> + Ptr CChar -> CULLong -> Ptr CChar -> IO CInt + +-------------------------------------------------------------------------------- +-- Documentation and notes + +-- $intro +-- +-- The simplest use of this library is one where you probably need to +-- sign short messages, so they can be verified independently. That's +-- easily done by first creating a keypair with @'createKeypair'@, and +-- using @'sign'@ to create a signed message. Then, you can distribute +-- your public key and the signed message, and any recipient can +-- verify that message: +-- +-- >>> (pk, sk) <- createKeypair +-- >>> let msg = sign sk "Hello world" +-- >>> verify pk msg +-- True +-- +-- This interface is fine if your messages are small and simple binary +-- blobs you want to verify in an opaque manner, but internally it +-- creates a copy of the input message. Often, you'll want the +-- signature independently of the message, and that can be done with +-- @'dsign'@ and @'dverify'@. Naturally, verification fails if the +-- message is incorrect: +-- +-- >>> (pk, sk) <- createKeypair +-- >>> let msg = "Hello world" :: ByteString +-- >>> let sig = dsign sk msg +-- >>> dverify pk msg sig +-- True +-- >>> dverify pk "Hello world" sig +-- True +-- >>> dverify pk "Goodbye world" sig +-- False +-- +-- Finally, it's worth keeping in mind this package doesn't expose any +-- kind of incremental interface, and signing/verification can be +-- expensive. So, if you're dealing with __large inputs__, you can +-- hash the input with a robust, fast cryptographic hash, and then +-- sign that (for example, the @hash@ function below could be +-- __SHA-512__ or __BLAKE2b__): +-- +-- >>> (pk, sk) <- createKeypair +-- >>> msg <- readBigFile "blob.tar.gz" :: IO ByteString +-- >>> let sig = dsign sk (hash msg) +-- >>> dverify pk (hash msg) sig +-- True +-- +-- See the notes at the bottom of this module for more on message +-- prehashing (as it acts slightly differently in an EdDSA system). + +-- $security +-- +-- Included below are some notes on the security aspects of the +-- Ed25519 signature system, its implementation and design, this +-- package, and suggestions for how you might use it properly. + + + +-- $background +-- +-- Ed25519 is a specific instantiation of the __EdDSA__ digital +-- signature scheme - a high performance, secure-by-design variant of +-- Schnorr signatures based on "Twisted Edwards Curves" (hence the +-- name __Ed__DSA). The (__extended__) EdDSA system is defined by an +-- elliptic curve: +-- +-- > ax^2 + y^2 = 1 + d*x^2*y^2 +-- +-- along with several other parameters, chosen by the implementation +-- in question. These parameters include @a@, @d@, and a field @GF(p)@ +-- where @p@ is prime. Ed25519 specifically uses @d = -121665/121666@, +-- @a = -1@, and the finite field @GF((2^155)-19)@, where @(2^155)-19@ +-- is a prime number (which is also the namesake of the algorithm in +-- question, as Ed__25519__). This yields the equation: +-- +-- > -x^2 + y^2 = 1 - (121665/121666)*x^2*y^2 +-- +-- This curve is \'birationally equivalent\' to the well-known +-- Montgomery curve \'Curve25519\', which means that EdDSA shares the +-- same the difficult problem as Curve25519: that of the Elliptic +-- Curve Discrete Logarithm Problem (ECDLP). Ed25519 is currently +-- still the recommended EdDSA curve for most deployments. +-- +-- As Ed25519 is an elliptic curve algorithm, the security level +-- (i.e. number of computations taken to find a solution to the ECDLP +-- with the fastest known attacks) is roughly half the key size in +-- bits, as it stands. As Ed25519 features 32-byte keys, the security +-- level of Ed25519 is thus @2^((32*8)/2) = 2^128@, far beyond any +-- attacker capability (modulo major breakthroughs for the ECDLP, +-- which would likely catastrophically be applicable to other systems +-- too). +-- +-- Ed25519 designed to meet the standard notion of unforgeability for +-- a public-key signature scheme under chosen-message attacks. This +-- means that even should the attacker be able to request someone sign +-- any arbitrary message of their choice (hence /chosen-message/), +-- they are still not capable of any forgery what-so-ever, even the +-- weakest kind of \'existential forgery\'. + + +-- $seedgen +-- +-- Seed generation as done by @'createKeypair'@ uses Operating System +-- provided APIs for generating cryptographically secure psuedo-random +-- data to be used as an Ed25519 key seed. Your own deterministic keys +-- may be generated using @'createKeypairFromSeed_'@, provided you have +-- your own cryptographically secure psuedo-random data from +-- somewhere. +-- +-- On __Linux__, __OS X__ and __other Unix__ machines, the +-- @\/dev\/urandom@ device is consulted internally in order to generate +-- random data. In the current implementation, a global file +-- descriptor is used through the lifetime of the program to +-- periodically get psuedo-random data. +-- +-- On __Windows__, the @CryptGenRandom@ API is used internally. This +-- does not require file handles of any kind, and should work on all +-- versions of Windows. (Windows may instead use @RtlGenRandom@ in the +-- future for even less overhead.) +-- +-- In the future, there are plans for this package to internally take +-- advantage of better APIs when they are available; for example, on +-- Linux 3.17 and above, @getrandom(2)@ provides psuedo-random data +-- directly through the internal pool provided by @\/dev\/urandom@, +-- without a file descriptor. Similarly, OpenBSD provides the +-- @arc4random(3)@ family of functions, which internally uses a data +-- generator based on ChaCha20. These should offer somewhat better +-- efficiency, and also avoid file-descriptor exhaustion attacks which +-- could lead to denial of service in some scenarios. + + + +-- $performance +-- +-- Ed25519 is exceptionally fast, although the implementation provided +-- by this package is not the fastest possible implementation. Indeed, +-- it is rather slow, even by non-handwritten-assembly standards of +-- speed. That said, it should still be competitive with most other +-- signature schemes: the underlying implementation is @ref10@ from +-- , authored by Daniel J. Bernstein, +-- which is within the +-- +-- against some assembly implementations (only 2x slower), and much +-- faster than the slow reference implementation (25x slower). When up +-- +-- signatures (ronald3072) on a modern Intel machine, it is still __15x__ +-- faster at signing messages /at the same 128-bit security level/. +-- +-- On the author's Sandy Bridge i5-2520M 2.50GHz CPU, the benchmarking +-- code included with the library reports the following numbers for +-- the Haskell interface: +-- +-- @ +-- benchmarking deterministic key generation +-- time 250.0 μs (249.8 μs .. 250.3 μs) +-- 1.000 R² (1.000 R² .. 1.000 R²) +-- mean 250.0 μs (249.9 μs .. 250.2 μs) +-- std dev 467.0 ns (331.7 ns .. 627.9 ns) +-- +-- benchmarking signing a 256 byte message +-- time 273.2 μs (273.0 μs .. 273.4 μs) +-- 1.000 R² (1.000 R² .. 1.000 R²) +-- mean 273.3 μs (273.1 μs .. 273.5 μs) +-- std dev 616.2 ns (374.1 ns .. 998.8 ns) +-- +-- benchmarking verifying a signature +-- time 635.7 μs (634.6 μs .. 637.3 μs) +-- 1.000 R² (1.000 R² .. 1.000 R²) +-- mean 635.4 μs (635.0 μs .. 636.0 μs) +-- std dev 1.687 μs (999.3 ns .. 2.487 μs) +-- +-- benchmarking roundtrip 256-byte sign/verify +-- time 923.6 μs (910.0 μs .. 950.6 μs) +-- 0.998 R² (0.996 R² .. 1.000 R²) +-- mean 913.2 μs (910.6 μs .. 923.0 μs) +-- std dev 15.93 μs (1.820 μs .. 33.72 μs) +-- @ +-- +-- In the future, this package will hopefully provide an opt-in (or +-- possibly default) implementation of +-- , which +-- should dramatically increase speed at no cost for many/all +-- platforms. + + + +-- $keystorage +-- +-- By default, keys are not encrypted in any meaningful manner with +-- any mechanism, and this package does not provide any means of doing +-- so. As a result, your secret keys are only as secure as the +-- computing environment housing them - a server alone out on the +-- hostile internet, or a USB stick that's susceptable to theft. +-- +-- If you wish to add some security to your keys, a very simple and +-- effective way is __to add a password to your @'SecretKey'@ with a__ +-- __KDF and a hash__. How does this work? +-- +-- * First, hash the secret key you have generated. Use this as a +-- __checksum__ of the original key. Truncating this hash to save +-- space is acceptable; see below for more details and boring +-- hemming and hawing. +-- +-- * Given an input password, use a KDF to stretch it to the length +-- of a @'SecretKey'@. +-- +-- * XOR the @'SecretKey'@ bytewise, directly with the output of +-- your chosen KDF. +-- +-- * Attach the checksum you generated to the resulting encrypted +-- key, and store it as you like. +-- +-- In this mode, your key is XOR'd with the psuedo-random result of a +-- KDF, which will stretch simple passwords like "I am the robot" into +-- a suitable amount of psuedo-random data for a given secret key to +-- be encrypted with. Decryption is simply the act of taking the +-- password, generating the psuedo-random stream again, XORing the key +-- bytewise, and validating the checksum. In this sense, you are +-- simply using a KDF as a short stream cipher. +-- +-- __Recommendation__: Encrypt keys by stretching a password with +-- __scrypt__ (or __yescrypt__), using better-than-default parameters. +-- (These being @N = 2^14@, @r = 8@, @p = 1@; the default results in +-- 16mb of memory per invocation, and this is the recommended default +-- for 'interactive systems'; signing keys may be loaded on-startup +-- for some things however, so it may be profitable to increase +-- security as well as memory use in these cases. For example, at @N = +-- 2^18@, @r = 10@ and @p = 2@, you'll get 320mb of memory per use, +-- which may be acceptable for dramatic security increases. See +-- elsewhere for exact memory use.) Checksums may be computed with an +-- exceptionally fast hash such as __BLAKE2b__. +-- +-- __Bonus points__: Print that resulting checksum + key out on a +-- piece of paper (~100 bytes, tops), and put /that/ somewhere safe. +-- +-- __Q__: What is the hash needed for? __A__: A simple file integrity +-- check. Rather than invoke complicated methods of verifying if an +-- ed25519 keypair is valid (as it is simply an opaque binary blob, +-- for all intents and purposes), especially after 'streaming +-- decryption', it's far easier to simply compute and compare against +-- a checksum of the original to determine if decryption with your +-- password worked. +-- +-- __Q__: Wait, why is it OK to truncate the hash here? That sounds +-- scary. Won't that open up collisions or something like that if they +-- stole my encrypted key? __A__: No. The hash in this case is only +-- used as a checksum to see if the password is legitimate after +-- running the KDF and XORing with the result. Think about how the +-- \'challenge\' itself is chosen: if you know @H(m)@, do you want to +-- find @m@ itself, or simply find @m'@ where @H(m') = H(m)@? To +-- forge a signature, you want the original key, @m@. Suppose given an +-- input of 256-bits, we hashed it and truncated to one bit. Finding +-- collisions would be easy: you would only need to try a few times to +-- find a collision or preimage. But you probably found @m'@ such that +-- @H(m') = H(m)@ - you didn't necessarily find @m@ itself. In this +-- sense, finding collisions or preimages of the hash is not useful to +-- the attacker, because you must find the unique @m@. +-- +-- __Q__: Okay, why use hashes at all? Why not CRC32? __A__: You could +-- do that, it wouldn't change much. You can really use any kind of +-- error detecting code you want. The thing is, some hashes such as +-- __BLAKE2__ are very fast in things like software (not every CPU has +-- CRC instructions, not all software uses CRC instructions), and +-- you're likely to already have a fast, modern hash function sitting +-- around anyway if you're signing stuff with Ed25519. Why not use it? + + + +-- $prehashing +-- +-- __Message prehashing__ (although not an official term in any right) +-- is the idea of first taking an input @x@, using a +-- __cryptographically secure__ hash function @H@ to calculate @y = +-- H(x)@, and then generating a signature via @Sign(secretKey, +-- y)@. The idea is that signing is often expensive, while hashing is +-- often extremely fast. As a result, signing the hash of a message +-- (which should be indistinguishable from a truly random function) is +-- often faster than simply signing the full message alone, and in +-- larger cases can save a significant amount of CPU cycles. However, +-- internally Ed25519 uses a hash function @H@ already to hash the +-- input message for computing the signature. Thus, there is a +-- question - is it appropriate or desireable to hash the input +-- already if this is the case? +-- +-- Generally speaking, it's OK to prehash messages before giving them +-- to Ed25519. However, there is a caveat. In the paper +-- , +-- the authors of the original EdDSA enhance the specification by +-- extending it with a message prehash function, @H'@, along with an +-- internal hash @H@. Here, the prehash @H'@ is simply applied to the +-- original message first before anything else. The original EdDSA +-- specification (and the implementation in /this package/) was a +-- trivial case of this enhancement: it was implicit that @H'@ is +-- simply the identity function. We call the case where @H'@ is the +-- identity function __PureEdDSA__, while the case where @H'@ is a +-- cryptographic hash function is known as __HashEdDSA__. (Thus, the +-- interfaces @'sign'@ and @'dsign'@ implement PureEdDSA - while they can +-- be converted to HashEdDSA by simply hashing the @'ByteString'@ +-- first with some other function.) +-- +-- However, the authors note that HashEdDSA suffers from a weakness +-- that PureEdDSA does not - PureEdDSA is resiliant to collision +-- attacks in the underlying hash function @H@, while HashEdDSA is +-- vulnerable to collisions in @H'@. This is an important +-- distinction. Assume that the attacker finds a collision such that +-- @H'(x) = H'(y)@, and then gets convinces a signer to HashEdDSA-sign +-- @x@ - the attacker may then forge this signature and use it as the +-- same signature as for the message @y@. For a hash function of +-- @N@-bits of output, a collision attack takes roughly @2^(N/2)@ +-- operations. +-- +-- Ed25519 internally sets @H = SHA-512@ anyway, which has no known +-- collision attacks or weaknesses in any meaningful sense. It is +-- however slower compared to other, more modern hash functions, and +-- is used on the input message in its entirety (and there are no +-- plans to switch the internal implementation of this package, or the +-- standard Ed25519 away from @H = SHA-512@). +-- +-- But note: /all other hash-then-sign constructions suffer from/ +-- /this/, in the sense they are all vulnerable to collision attacks +-- in @H'@, should you prehash the message. In fact, PureEdDSA is +-- unique (as far as I am aware) in that it is immune to collision +-- attacks in @H@ - should a collision be found, it would not suffer +-- from these forgeries. By this view, it's arguable that /depending/ +-- on the HashEdDSA construction (for efficiency or size purposes) +-- when using EdDSA is somewhat less robust, even if SHA-512 or +-- whatever is not very fast. Despite that, just about any /modern/ +-- /hash/ you pick is going to be collision resistant to a fine degree +-- (say, 256 bits of output, therefore collisions 'at best' happen in +-- @2^128@ operations), so in practice this robustness issue may not +-- be that big of a deal. +-- +-- However, the more pertinent issue is that due to the current design +-- of the API which requires the entire blob to sign up front, using +-- the HashEdDSA construction is often much more convenient, faster +-- and sometimes /necessary/ too. For example, when signing very large +-- messages (such as creating a very large @tar.gz@ file which you +-- wish to sign after creation), it is often convenient and possible +-- to use \'incremental\' hashing APIs to incrementally consume data +-- blocks from the input in a constant amount of memory. At the end of +-- consumption, you can \'finalize\' the data blocks and get back a +-- final N-bit hash, and sign this hash all in a constant amount of +-- memory. With the current API, using PureDSA would require you +-- loading the entire file up front to either sign, or verify it. This +-- is especially unoptimal for possibly smaller, low-memory systems +-- (where decompression, hashing or verification are all best done in +-- constant space if possible). +-- +-- Beware however, that if you do this sort of incremental hashing for +-- large blobs, you are __taking untrusted data__ and hashing it +-- __before checking the signature__ - be __exceptionally careful__ +-- with data from a possibly untrustworthy source until you can verify +-- the signature. +-- +-- So, __some basic guidelines are__: +-- +-- - If you are simply not worried about efficiency very much, just +-- use __PureEdDSA__ (i.e. just use @'sign'@ and @'verify'@ +-- directly). +-- +-- - If you have __lots of small messages__, use __PureEdDSA__ (i.e. +-- just use @'sign'@ and @'verify'@ directly). +-- +-- - If you have to sign/verify __large messages__, possibly __in__ +-- __an incremental fashion__, use __HashEdDSA__ with __a fast__ +-- __hash__ (i.e. just hash a message before using @'sign'@ or +-- @'verify'@ on it). +-- +-- - A hash like __BLAKE2b__ is recommended. Fast and very secure. +-- +-- - Remember: __never touch input data in any form until you__ +-- __are done hashing it and verifying the signature__. +-- +-- As a result, you should be safe hashing your input before passing +-- it to @'sign'@ or @'dsign'@ in this library if you desire, and it may +-- save you CPU cycles for large inputs. It should be no different +-- than the typical /hash-then-sign/ construction you see elsewhere, +-- with the same downfalls. Should you do this, an extremely +-- fast-yet-secure hash such as __BLAKE2b__ is recommended, which is +-- even faster than MD5 or SHA-1 (and __do not ever use MD5 or__ +-- __SHA-1__, on that note - they suffer from collision attacks). diff --git a/bundled/Data/ByteArray.hs b/bundled/Data/ByteArray.hs new file mode 100644 index 0000000..32455c6 --- /dev/null +++ b/bundled/Data/ByteArray.hs @@ -0,0 +1,34 @@ +-- | +-- Module : Data.ByteArray +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +-- Simple and efficient byte array types +-- +-- This module should be imported qualified. +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Data.ByteArray + ( + -- * ByteArray Classes + module Data.ByteArray.Types + -- * ByteArray built-in types + , module Data.ByteArray.Bytes + , module Data.ByteArray.ScrubbedBytes + , module Data.ByteArray.MemView + , module Data.ByteArray.View + -- * ByteArray methods + , module Data.ByteArray.Methods + ) where + +import Data.ByteArray.Types +import Data.ByteArray.Methods +import Data.ByteArray.ScrubbedBytes (ScrubbedBytes) +import Data.ByteArray.Bytes (Bytes) +import Data.ByteArray.MemView (MemView(..)) +import Data.ByteArray.View (View, view, takeView, dropView) diff --git a/bundled/Data/ByteArray/Bytes.hs b/bundled/Data/ByteArray/Bytes.hs new file mode 100644 index 0000000..8d7a870 --- /dev/null +++ b/bundled/Data/ByteArray/Bytes.hs @@ -0,0 +1,216 @@ +-- | +-- Module : Data.ByteArray.Bytes +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +-- Simple and efficient byte array types +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Data.ByteArray.Bytes + ( Bytes + ) where + +#if MIN_VERSION_base(4,15,0) +import GHC.Exts (unsafeCoerce#) +#endif +import GHC.Word +import GHC.Char (chr) +import GHC.Types +import GHC.Prim +import GHC.Ptr +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup +import Data.Foldable (toList) +#else +import Data.Monoid +#endif +import Data.Memory.PtrMethods +import Data.Memory.Internal.Imports +import Data.Memory.Internal.CompatPrim +import Data.Memory.Internal.Compat (unsafeDoIO) +import Data.ByteArray.Types +import Data.Typeable + +#ifdef MIN_VERSION_basement +import Basement.NormalForm +#endif +import Basement.IntegralConv + +-- | Simplest Byte Array +data Bytes = Bytes (MutableByteArray# RealWorld) + deriving (Typeable) + +instance Show Bytes where + showsPrec p b r = showsPrec p (bytesUnpackChars b []) r +instance Eq Bytes where + (==) = bytesEq +instance Ord Bytes where + compare = bytesCompare +#if MIN_VERSION_base(4,9,0) +instance Semigroup Bytes where + b1 <> b2 = unsafeDoIO $ bytesAppend b1 b2 + sconcat = unsafeDoIO . bytesConcat . toList +#endif +instance Monoid Bytes where + mempty = unsafeDoIO (newBytes 0) +#if !(MIN_VERSION_base(4,11,0)) + mappend b1 b2 = unsafeDoIO $ bytesAppend b1 b2 + mconcat = unsafeDoIO . bytesConcat +#endif +instance NFData Bytes where + rnf b = b `seq` () +#ifdef MIN_VERSION_basement +instance NormalForm Bytes where + toNormalForm b = b `seq` () +#endif +instance ByteArrayAccess Bytes where + length = bytesLength + withByteArray = withBytes +instance ByteArray Bytes where + allocRet = bytesAllocRet + +------------------------------------------------------------------------ +newBytes :: Int -> IO Bytes +newBytes (I# sz) + | booleanPrim (sz <# 0#) = error "Bytes: size must be >= 0" + | otherwise = IO $ \s -> + case newAlignedPinnedByteArray# sz 8# s of + (# s', mbarr #) -> (# s', Bytes mbarr #) + +touchBytes :: Bytes -> IO () +touchBytes (Bytes mba) = IO $ \s -> case touch# mba s of s' -> (# s', () #) +{-# INLINE touchBytes #-} + +sizeofBytes :: Bytes -> Int +sizeofBytes (Bytes mba) = I# (sizeofMutableByteArray# mba) +{-# INLINE sizeofBytes #-} + +withPtr :: Bytes -> (Ptr p -> IO a) -> IO a +withPtr b@(Bytes mba) f = do + a <- f (Ptr (byteArrayContents# (unsafeCoerce# mba))) + touchBytes b + return a +------------------------------------------------------------------------ + +bytesAlloc :: Int -> (Ptr p -> IO ()) -> IO Bytes +bytesAlloc sz f = do + ba <- newBytes sz + withPtr ba f + return ba + +bytesConcat :: [Bytes] -> IO Bytes +bytesConcat l = bytesAlloc retLen (copy l) + where + !retLen = sum $ map bytesLength l + + copy [] _ = return () + copy (x:xs) dst = do + withPtr x $ \src -> memCopy dst src chunkLen + copy xs (dst `plusPtr` chunkLen) + where + !chunkLen = bytesLength x + +bytesAppend :: Bytes -> Bytes -> IO Bytes +bytesAppend b1 b2 = bytesAlloc retLen $ \dst -> do + withPtr b1 $ \s1 -> memCopy dst s1 len1 + withPtr b2 $ \s2 -> memCopy (dst `plusPtr` len1) s2 len2 + where + !len1 = bytesLength b1 + !len2 = bytesLength b2 + !retLen = len1 + len2 + +bytesAllocRet :: Int -> (Ptr p -> IO a) -> IO (a, Bytes) +bytesAllocRet sz f = do + ba <- newBytes sz + r <- withPtr ba f + return (r, ba) + +bytesLength :: Bytes -> Int +bytesLength = sizeofBytes +{-# LANGUAGE bytesLength #-} + +withBytes :: Bytes -> (Ptr p -> IO a) -> IO a +withBytes = withPtr + +bytesEq :: Bytes -> Bytes -> Bool +bytesEq b1@(Bytes m1) b2@(Bytes m2) + | l1 /= l2 = False + | otherwise = unsafeDoIO $ IO $ \s -> loop 0# s + where + !l1@(I# len) = bytesLength b1 + !l2 = bytesLength b2 + + loop i s + | booleanPrim (i ==# len) = (# s, True #) + | otherwise = + case readWord8Array# m1 i s of + (# s', e1 #) -> case readWord8Array# m2 i s' of + (# s'', e2 #) -> + if (W8# e1) == (W8# e2) + then loop (i +# 1#) s'' + else (# s'', False #) + {-# INLINE loop #-} + +bytesCompare :: Bytes -> Bytes -> Ordering +bytesCompare b1@(Bytes m1) b2@(Bytes m2) = unsafeDoIO $ loop 0 + where + !l1 = bytesLength b1 + !l2 = bytesLength b2 + !len = min l1 l2 + + loop !i + | i == len = + if l1 == l2 + then pure EQ + else if l1 > l2 then pure GT + else pure LT + | otherwise = do + e1 <- read8 m1 i + e2 <- read8 m2 i + if e1 == e2 + then loop (i+1) + else if e1 < e2 then pure LT + else pure GT + + read8 m (I# i) = IO $ \s -> case readWord8Array# m i s of + (# s2, e #) -> (# s2, W8# e #) + +bytesUnpackChars :: Bytes -> String -> String +bytesUnpackChars (Bytes mba) xs = chunkLoop 0# + where + !len = sizeofMutableByteArray# mba + -- chunk 64 bytes at a time + chunkLoop :: Int# -> [Char] + chunkLoop idx + | booleanPrim (len ==# idx) = [] + | booleanPrim ((len -# idx) ># 63#) = + bytesLoop idx 64# (chunkLoop (idx +# 64#)) + | otherwise = + bytesLoop idx (len -# idx) xs + + bytesLoop idx chunkLenM1 paramAcc = unsafeDoIO $ + loop (idx +# chunkLenM1 -# 1#) paramAcc + where loop i acc + | booleanPrim (i ==# idx) = do + c <- rChar i + return (c : acc) + | otherwise = do + c <- rChar i + loop (i -# 1#) (c : acc) + + rChar :: Int# -> IO Char + rChar idx = IO $ \s -> + case readWord8Array# mba idx s of + (# s2, w #) -> (# s2, chr (integralUpsize (W8# w)) #) + +{- +bytesShowHex :: Bytes -> String +bytesShowHex b = showHexadecimal (withPtr b) (bytesLength b) +{-# NOINLINE bytesShowHex #-} +-} diff --git a/bundled/Data/ByteArray/Encoding.hs b/bundled/Data/ByteArray/Encoding.hs new file mode 100644 index 0000000..3210fb9 --- /dev/null +++ b/bundled/Data/ByteArray/Encoding.hs @@ -0,0 +1,162 @@ +-- | +-- Module : Data.ByteArray.Encoding +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Base conversions for 'ByteArray'. +-- +module Data.ByteArray.Encoding + ( convertToBase + , convertFromBase + , Base(..) + ) where + +import Data.ByteArray.Types +import qualified Data.ByteArray.Types as B +import qualified Data.ByteArray.Methods as B +import Data.Memory.Internal.Compat +import Data.Memory.Encoding.Base16 +import Data.Memory.Encoding.Base32 +import Data.Memory.Encoding.Base64 + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.ByteString + +-- | The different bases that can be used. +-- +-- See for details. +-- In particular, Base64 can be standard or +-- . URL-safe +-- encoding is often used in other specifications without +-- characters. +-- +-- +-- defines a separate Base64 encoding, which is not supported. This format +-- requires a newline at least every 76 encoded characters, which works around +-- limitations of older email programs that could not handle long lines. +-- Be aware that other languages, such as Ruby, encode the RFC 2045 version +-- by default. To decode their output, remove all newlines before decoding. +-- +-- ==== Examples +-- +-- A quick example to show the differences: +-- +-- >>> let input = "Is 3 > 2?" :: ByteString +-- >>> let convertedTo base = convertToBase base input :: ByteString +-- >>> convertedTo Base16 +-- "49732033203e20323f" +-- >>> convertedTo Base32 +-- "JFZSAMZAHYQDEPY=" +-- >>> convertedTo Base64 +-- "SXMgMyA+IDI/" +-- >>> convertedTo Base64URLUnpadded +-- "SXMgMyA-IDI_" +-- >>> convertedTo Base64OpenBSD +-- "QVKeKw.8GBG9" +-- +data Base = Base16 -- ^ similar to hexadecimal + | Base32 + | Base64 -- ^ standard Base64 + | Base64URLUnpadded -- ^ unpadded URL-safe Base64 + | Base64OpenBSD -- ^ Base64 as used in OpenBSD password encoding (such as bcrypt) + deriving (Show,Eq) + +-- | Encode some bytes to the equivalent representation in a specific 'Base'. +-- +-- ==== Examples +-- +-- Convert a 'ByteString' to base-64: +-- +-- >>> convertToBase Base64 ("foobar" :: ByteString) :: ByteString +-- "Zm9vYmFy" +-- +convertToBase :: (ByteArrayAccess bin, ByteArray bout) => Base -> bin -> bout +convertToBase base b = case base of + Base16 -> doConvert (binLength * 2) toHexadecimal + Base32 -> let (q,r) = binLength `divMod` 5 + outLen = 8 * (if r == 0 then q else q + 1) + in doConvert outLen toBase32 + Base64 -> doConvert base64Length toBase64 + -- Base64URL -> doConvert base64Length (toBase64URL True) + Base64URLUnpadded -> doConvert base64UnpaddedLength (toBase64URL False) + Base64OpenBSD -> doConvert base64UnpaddedLength toBase64OpenBSD + where + binLength = B.length b + + base64Length = let (q,r) = binLength `divMod` 3 + in 4 * (if r == 0 then q else q+1) + + base64UnpaddedLength = let (q,r) = binLength `divMod` 3 + in 4 * q + (if r == 0 then 0 else r+1) + doConvert l f = + B.unsafeCreate l $ \bout -> + B.withByteArray b $ \bin -> + f bout bin binLength + +-- | Try to decode some bytes from the equivalent representation in a specific 'Base'. +-- +-- ==== Examples +-- +-- Successfully convert from base-64 to a 'ByteString': +-- +-- >>> convertFromBase Base64 ("Zm9vYmFy" :: ByteString) :: Either String ByteString +-- Right "foobar" +-- +-- Trying to decode invalid data will return an error string: +-- +-- >>> convertFromBase Base64 ("!!!" :: ByteString) :: Either String ByteString +-- Left "base64: input: invalid length" +-- +convertFromBase :: (ByteArrayAccess bin, ByteArray bout) => Base -> bin -> Either String bout +convertFromBase Base16 b + | odd (B.length b) = Left "base16: input: invalid length" + | otherwise = unsafeDoIO $ do + (ret, out) <- + B.allocRet (B.length b `div` 2) $ \bout -> + B.withByteArray b $ \bin -> + fromHexadecimal bout bin (B.length b) + case ret of + Nothing -> return $ Right out + Just ofs -> return $ Left ("base16: input: invalid encoding at offset: " ++ show ofs) +convertFromBase Base32 b = unsafeDoIO $ + withByteArray b $ \bin -> do + mDstLen <- unBase32Length bin (B.length b) + case mDstLen of + Nothing -> return $ Left "base32: input: invalid length" + Just dstLen -> do + (ret, out) <- B.allocRet dstLen $ \bout -> fromBase32 bout bin (B.length b) + case ret of + Nothing -> return $ Right out + Just ofs -> return $ Left ("base32: input: invalid encoding at offset: " ++ show ofs) +convertFromBase Base64 b = unsafeDoIO $ + withByteArray b $ \bin -> do + mDstLen <- unBase64Length bin (B.length b) + case mDstLen of + Nothing -> return $ Left "base64: input: invalid length" + Just dstLen -> do + (ret, out) <- B.allocRet dstLen $ \bout -> fromBase64 bout bin (B.length b) + case ret of + Nothing -> return $ Right out + Just ofs -> return $ Left ("base64: input: invalid encoding at offset: " ++ show ofs) +convertFromBase Base64URLUnpadded b = unsafeDoIO $ + withByteArray b $ \bin -> + case unBase64LengthUnpadded (B.length b) of + Nothing -> return $ Left "base64URL unpadded: input: invalid length" + Just dstLen -> do + (ret, out) <- B.allocRet dstLen $ \bout -> fromBase64URLUnpadded bout bin (B.length b) + case ret of + Nothing -> return $ Right out + Just ofs -> return $ Left ("base64URL unpadded: input: invalid encoding at offset: " ++ show ofs) +convertFromBase Base64OpenBSD b = unsafeDoIO $ + withByteArray b $ \bin -> + case unBase64LengthUnpadded (B.length b) of + Nothing -> return $ Left "base64 unpadded: input: invalid length" + Just dstLen -> do + (ret, out) <- B.allocRet dstLen $ \bout -> fromBase64OpenBSD bout bin (B.length b) + case ret of + Nothing -> return $ Right out + Just ofs -> return $ Left ("base64 unpadded: input: invalid encoding at offset: " ++ show ofs) + diff --git a/bundled/Data/ByteArray/Hash.hs b/bundled/Data/ByteArray/Hash.hs new file mode 100644 index 0000000..14f65b8 --- /dev/null +++ b/bundled/Data/ByteArray/Hash.hs @@ -0,0 +1,78 @@ +-- | +-- Module : Data.ByteArray.Hash +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : good +-- +-- provide the SipHash algorithm. +-- reference: +-- +{-# LANGUAGE BangPatterns #-} +module Data.ByteArray.Hash + ( + -- * SipHash + SipKey(..) + , SipHash(..) + , sipHash + , sipHashWith + -- * FNV1 and FNV1a (32 and 64 bits) + , FnvHash32(..) + , FnvHash64(..) + , fnv1Hash + , fnv1aHash + , fnv1_64Hash + , fnv1a_64Hash + ) where + +import Data.Memory.Internal.Compat +import Data.Memory.Hash.SipHash +import Data.Memory.Hash.FNV +import qualified Data.ByteArray.Types as B + +-- | Compute the SipHash tag of a byte array for a given key. +-- +-- 'sipHash` is equivalent to 'sipHashWith 2 4' +sipHash :: B.ByteArrayAccess ba + => SipKey + -> ba + -> SipHash +sipHash key ba = unsafeDoIO $ B.withByteArray ba $ \p -> hash key p (B.length ba) + +-- | Compute the SipHash tag of a byte array for a given key. +-- +-- The user can choose the C and D numbers of rounds. +-- +-- calling 'sipHash` is equivalent to 'sipHashWith 2 4' +sipHashWith :: B.ByteArrayAccess ba + => Int -- ^ c rounds + -> Int -- ^ d rounds + -> SipKey -- ^ key + -> ba -- ^ data to hash + -> SipHash +sipHashWith c d key ba = unsafeDoIO $ B.withByteArray ba $ \p -> hashWith c d key p (B.length ba) + + +-- | Compute the FNV1 32 bit hash value of a byte array +fnv1Hash :: B.ByteArrayAccess ba + => ba + -> FnvHash32 +fnv1Hash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1 p (B.length ba) + +-- | Compute the FNV1a 32 bit hash value of a byte array +fnv1aHash :: B.ByteArrayAccess ba + => ba + -> FnvHash32 +fnv1aHash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1a p (B.length ba) + +-- | Compute the FNV1 64 bit hash value of a byte array +fnv1_64Hash :: B.ByteArrayAccess ba + => ba + -> FnvHash64 +fnv1_64Hash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1_64 p (B.length ba) + +-- | Compute the FNV1a 64 bit hash value of a byte array +fnv1a_64Hash :: B.ByteArrayAccess ba + => ba + -> FnvHash64 +fnv1a_64Hash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1a_64 p (B.length ba) diff --git a/bundled/Data/ByteArray/Mapping.hs b/bundled/Data/ByteArray/Mapping.hs new file mode 100644 index 0000000..896766b --- /dev/null +++ b/bundled/Data/ByteArray/Mapping.hs @@ -0,0 +1,84 @@ +-- | +-- Module : Data.ByteArray.Mapping +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +module Data.ByteArray.Mapping + ( toW64BE + , toW64LE + , fromW64BE + , mapAsWord64 + , mapAsWord128 + ) where + +import Data.ByteArray.Types +import Data.ByteArray.Methods +import Data.Memory.Internal.Compat +import Data.Memory.Internal.Imports hiding (empty) +import Data.Memory.Endian +import Data.Memory.ExtendedWords +import Foreign.Storable +import Foreign.Ptr + +import Prelude hiding (length, take, drop, span, concat, replicate, splitAt, null, pred) + +-- | Transform a bytearray at a specific offset into +-- a Word64 tagged as BE (Big Endian) +-- +-- no bounds checking. unsafe +toW64BE :: ByteArrayAccess bs => bs -> Int -> BE Word64 +toW64BE bs ofs = unsafeDoIO $ withByteArray bs $ \p -> peek (p `plusPtr` ofs) + +-- | Transform a bytearray at a specific offset into +-- a Word64 tagged as LE (Little Endian) +-- +-- no bounds checking. unsafe +toW64LE :: ByteArrayAccess bs => bs -> Int -> LE Word64 +toW64LE bs ofs = unsafeDoIO $ withByteArray bs $ \p -> peek (p `plusPtr` ofs) + +-- | Serialize a @Word64@ to a @ByteArray@ in big endian format +fromW64BE :: (ByteArray ba) => Word64 -> ba +fromW64BE n = allocAndFreeze 8 $ \p -> poke p (toBE n) + +-- | map blocks of 128 bits of a bytearray, creating a new bytestring +-- of equivalent size where each blocks has been mapped through @f@ +-- +-- no length checking is done. unsafe +mapAsWord128 :: ByteArray bs => (Word128 -> Word128) -> bs -> bs +mapAsWord128 f bs = + unsafeCreate len $ \dst -> + withByteArray bs $ \src -> + loop (len `div` 16) dst src + where + len = length bs + loop :: Int -> Ptr (BE Word64) -> Ptr (BE Word64) -> IO () + loop 0 _ _ = return () + loop i d s = do + w1 <- peek s + w2 <- peek (s `plusPtr` 8) + let (Word128 r1 r2) = f (Word128 (fromBE w1) (fromBE w2)) + poke d (toBE r1) + poke (d `plusPtr` 8) (toBE r2) + loop (i-1) (d `plusPtr` 16) (s `plusPtr` 16) + +-- | map blocks of 64 bits of a bytearray, creating a new bytestring +-- of equivalent size where each blocks has been mapped through @f@ +-- +-- no length checking is done. unsafe +mapAsWord64 :: ByteArray bs => (Word64 -> Word64) -> bs -> bs +mapAsWord64 f bs = + unsafeCreate len $ \dst -> + withByteArray bs $ \src -> + loop (len `div` 8) dst src + where + len = length bs + + loop :: Int -> Ptr (BE Word64) -> Ptr (BE Word64) -> IO () + loop 0 _ _ = return () + loop i d s = do + w <- peek s + let r = f (fromBE w) + poke d (toBE r) + loop (i-1) (d `plusPtr` 8) (s `plusPtr` 8) diff --git a/bundled/Data/ByteArray/MemView.hs b/bundled/Data/ByteArray/MemView.hs new file mode 100644 index 0000000..cc5f6b2 --- /dev/null +++ b/bundled/Data/ByteArray/MemView.hs @@ -0,0 +1,38 @@ +-- | +-- Module : Data.ByteArray.MemView +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +module Data.ByteArray.MemView + ( MemView(..) + , memViewPlus + ) where + +import Foreign.Ptr +import Data.ByteArray.Types +import Data.Memory.Internal.Imports + +-- | A simple abstraction to a piece of memory. +-- +-- Do beware that garbage collection related to +-- piece of memory could be triggered before this +-- is used. +-- +-- Only use with the appropriate handler has been +-- used (e.g. withForeignPtr on ForeignPtr) +-- +data MemView = MemView {-# UNPACK #-} !(Ptr Word8) {-# UNPACK #-} !Int + deriving (Show,Eq) + +instance ByteArrayAccess MemView where + length (MemView _ l) = l + withByteArray (MemView p _) f = f (castPtr p) + +-- | Increase the memory view while reducing the size of the window +-- +-- this is useful as an abstraction to represent the current offset +-- in a buffer, and the remaining bytes left. +memViewPlus :: MemView -> Int -> MemView +memViewPlus (MemView p len) n = MemView (p `plusPtr` n) (len - n) diff --git a/bundled/Data/ByteArray/Methods.hs b/bundled/Data/ByteArray/Methods.hs new file mode 100644 index 0000000..3da5b41 --- /dev/null +++ b/bundled/Data/ByteArray/Methods.hs @@ -0,0 +1,312 @@ +-- | +-- Module : Data.ByteArray.Methods +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +module Data.ByteArray.Methods + ( alloc + , allocAndFreeze + , create + , unsafeCreate + , pack + , unpack + , uncons + , empty + , singleton + , cons + , snoc + , null + , replicate + , zero + , copy + , take + , drop + , span + , reverse + , convert + , copyRet + , copyAndFreeze + , splitAt + , xor + , index + , eq + , constEq + , any + , all + , append + , concat + ) where + +import Data.ByteArray.Types +import Data.Memory.Internal.Compat +import Data.Memory.Internal.Imports hiding (empty) +import Data.Memory.PtrMethods +import Data.Monoid +import Foreign.Storable +import Foreign.Ptr + +import Prelude hiding (length, take, drop, span, reverse, concat, replicate, splitAt, null, pred, last, any, all) +import qualified Prelude + +#if defined(WITH_BYTESTRING_SUPPORT) && defined(WITH_BASEMENT_SUPPORT) +import qualified Data.ByteString as SPE (ByteString) +import qualified Basement.UArray as SPE (UArray) +import qualified Basement.Block as SPE (Block) +#endif + +-- | Allocate a new bytearray of specific size, and run the initializer on this memory +alloc :: ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba +alloc n f + | n < 0 = alloc 0 f + | otherwise = snd `fmap` allocRet n f +{-# INLINE alloc #-} + +-- | Allocate a new bytearray of specific size, and run the initializer on this memory +create :: ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba +create n f = alloc n f + +-- | similar to 'alloc' but hide the allocation and initializer in a pure context +allocAndFreeze :: ByteArray a => Int -> (Ptr p -> IO ()) -> a +allocAndFreeze sz f = unsafeDoIO (alloc sz f) +{-# NOINLINE allocAndFreeze #-} + +-- | similar to 'create' but hide the allocation and initializer in a pure context +unsafeCreate :: ByteArray a => Int -> (Ptr p -> IO ()) -> a +unsafeCreate sz f = unsafeDoIO (alloc sz f) +{-# NOINLINE unsafeCreate #-} + +inlineUnsafeCreate :: ByteArray a => Int -> (Ptr p -> IO ()) -> a +inlineUnsafeCreate !sz f = unsafeDoIO (alloc sz f) +{-# INLINE inlineUnsafeCreate #-} + +-- | Create an empty byte array +empty :: ByteArray a => a +empty = unsafeDoIO (alloc 0 $ \_ -> return ()) + +-- | Check if a byte array is empty +null :: ByteArrayAccess a => a -> Bool +null b = length b == 0 + +-- | Pack a list of bytes into a bytearray +pack :: ByteArray a => [Word8] -> a +pack l = inlineUnsafeCreate (Prelude.length l) (fill l) + where fill [] _ = return () + fill (x:xs) !p = poke p x >> fill xs (p `plusPtr` 1) + {-# INLINE fill #-} +{-# NOINLINE pack #-} + +-- | Un-pack a bytearray into a list of bytes +unpack :: ByteArrayAccess a => a -> [Word8] +unpack bs = loop 0 + where !len = length bs + loop i + | i == len = [] + | otherwise = + let !v = unsafeDoIO $ withByteArray bs (\p -> peekByteOff p i) + in v : loop (i+1) + +-- | returns the first byte, and the remaining bytearray if the bytearray is not null +uncons :: ByteArray a => a -> Maybe (Word8, a) +uncons a + | null a = Nothing + | otherwise = Just (index a 0, drop 1 a) + +-- | Create a byte array from a single byte +singleton :: ByteArray a => Word8 -> a +singleton b = unsafeCreate 1 (\p -> pokeByteOff p 0 b) + +-- | prepend a single byte to a byte array +cons :: ByteArray a => Word8 -> a -> a +cons b ba = unsafeCreate (len + 1) $ \d -> withByteArray ba $ \s -> do + pokeByteOff d 0 b + memCopy (d `plusPtr` 1) s len + where len = length ba + +-- | append a single byte to a byte array +snoc :: ByteArray a => a -> Word8 -> a +snoc ba b = unsafeCreate (len + 1) $ \d -> withByteArray ba $ \s -> do + memCopy d s len + pokeByteOff d len b + where len = length ba + +-- | Create a xor of bytes between a and b. +-- +-- the returns byte array is the size of the smallest input. +xor :: (ByteArrayAccess a, ByteArrayAccess b, ByteArray c) => a -> b -> c +xor a b = + unsafeCreate n $ \pc -> + withByteArray a $ \pa -> + withByteArray b $ \pb -> + memXor pc pa pb n + where + n = min la lb + la = length a + lb = length b + +-- | return a specific byte indexed by a number from 0 in a bytearray +-- +-- unsafe, no bound checking are done +index :: ByteArrayAccess a => a -> Int -> Word8 +index b i = unsafeDoIO $ withByteArray b $ \p -> peek (p `plusPtr` i) + +-- | Split a bytearray at a specific length in two bytearray +splitAt :: ByteArray bs => Int -> bs -> (bs, bs) +splitAt n bs + | n <= 0 = (empty, bs) + | n >= len = (bs, empty) + | otherwise = unsafeDoIO $ do + withByteArray bs $ \p -> do + b1 <- alloc n $ \r -> memCopy r p n + b2 <- alloc (len - n) $ \r -> memCopy r (p `plusPtr` n) (len - n) + return (b1, b2) + where len = length bs + +-- | Take the first @n@ byte of a bytearray +take :: ByteArray bs => Int -> bs -> bs +take n bs + | n <= 0 = empty + | otherwise = unsafeCreate m $ \d -> withByteArray bs $ \s -> memCopy d s m + where + !m = min len n + !len = length bs + +-- | drop the first @n@ byte of a bytearray +drop :: ByteArray bs => Int -> bs -> bs +drop n bs + | n <= 0 = bs + | nb == 0 = empty + | otherwise = unsafeCreate nb $ \d -> withByteArray bs $ \s -> memCopy d (s `plusPtr` ofs) nb + where + ofs = min len n + nb = len - ofs + len = length bs + +-- | Split a bytearray at the point where @pred@ becomes invalid +span :: ByteArray bs => (Word8 -> Bool) -> bs -> (bs, bs) +span pred bs + | null bs = (bs, bs) + | otherwise = let n = loop 0 in (take n bs, drop n bs) + where loop !i + | i >= len = len + | pred (index bs i) = loop (i+1) + | otherwise = i + len = length bs + +-- | Reverse a bytearray +reverse :: ByteArray bs => bs -> bs +reverse bs = unsafeCreate n $ \d -> withByteArray bs $ \s -> memReverse d s n + where n = length bs + +-- | Concatenate bytearray into a larger bytearray +concat :: (ByteArrayAccess bin, ByteArray bout) => [bin] -> bout +concat l = unsafeCreate retLen (loopCopy l) + where + retLen = sum $ map length l + + loopCopy [] _ = return () + loopCopy (x:xs) dst = do + copyByteArrayToPtr x dst + loopCopy xs (dst `plusPtr` chunkLen) + where + !chunkLen = length x + +-- | append one bytearray to the other +append :: ByteArray bs => bs -> bs -> bs +append = mappend + +-- | Duplicate a bytearray into another bytearray, and run an initializer on it +copy :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO ()) -> IO bs2 +copy bs f = + alloc (length bs) $ \d -> do + copyByteArrayToPtr bs d + f (castPtr d) + +-- | Similar to 'copy' but also provide a way to return a value from the initializer +copyRet :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO a) -> IO (a, bs2) +copyRet bs f = + allocRet (length bs) $ \d -> do + copyByteArrayToPtr bs d + f (castPtr d) + +-- | Similiar to 'copy' but expect the resulting bytearray in a pure context +copyAndFreeze :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO ()) -> bs2 +copyAndFreeze bs f = + inlineUnsafeCreate (length bs) $ \d -> do + copyByteArrayToPtr bs d + f (castPtr d) +{-# NOINLINE copyAndFreeze #-} + +-- | Create a bytearray of a specific size containing a repeated byte value +replicate :: ByteArray ba => Int -> Word8 -> ba +replicate 0 _ = empty +replicate n b + | n < 0 = empty + | otherwise = inlineUnsafeCreate n $ \ptr -> memSet ptr b n +{-# NOINLINE replicate #-} + +-- | Create a bytearray of a specific size initialized to 0 +zero :: ByteArray ba => Int -> ba +zero 0 = empty +zero n + | n < 0 = empty + | otherwise = unsafeCreate n $ \ptr -> memSet ptr 0 n +{-# NOINLINE zero #-} + +-- | Check if two bytearray are equals +-- +-- This is not constant time, as soon some byte differs the function will +-- returns. use 'constEq' in sensitive context where timing matters. +eq :: (ByteArrayAccess bs1, ByteArrayAccess bs2) => bs1 -> bs2 -> Bool +eq b1 b2 + | l1 /= l2 = False + | otherwise = unsafeDoIO $ withByteArray b1 $ \p1 -> withByteArray b2 $ \p2 -> memEqual p1 p2 l1 + where + l1 = length b1 + l2 = length b2 + +-- | A constant time equality test for 2 ByteArrayAccess values. +-- +-- If values are of 2 different sizes, the function will abort early +-- without comparing any bytes. +-- +-- compared to == , this function will go over all the bytes +-- present before yielding a result even when knowing the +-- overall result early in the processing. +constEq :: (ByteArrayAccess bs1, ByteArrayAccess bs2) => bs1 -> bs2 -> Bool +constEq b1 b2 + | l1 /= l2 = False + | otherwise = unsafeDoIO $ withByteArray b1 $ \p1 -> withByteArray b2 $ \p2 -> memConstEqual p1 p2 l1 + where + !l1 = length b1 + !l2 = length b2 + +-- | Check if any element of a byte array satisfies a predicate +any :: (ByteArrayAccess ba) => (Word8 -> Bool) -> ba -> Bool +any f b + | null b = False + | otherwise = unsafeDoIO $ withByteArray b $ \p -> loop p 0 + where + len = length b + loop p i + | i == len = return False + | otherwise = do + w <- peekByteOff p i + if f w then return True else loop p (i+1) + +-- | Check if all elements of a byte array satisfy a predicate +all :: (ByteArrayAccess ba) => (Word8 -> Bool) -> ba -> Bool +all f b = not (any (not . f) b) + +-- | Convert a bytearray to another type of bytearray +convert :: (ByteArrayAccess bin, ByteArray bout) => bin -> bout +convert bs = inlineUnsafeCreate (length bs) (copyByteArrayToPtr bs) +#if defined(WITH_BYTESTRING_SUPPORT) && defined(WITH_BASEMENT_SUPPORT) +{-# SPECIALIZE convert :: SPE.ByteString -> SPE.UArray Word8 #-} +{-# SPECIALIZE convert :: SPE.UArray Word8 -> SPE.ByteString #-} +{-# SPECIALIZE convert :: SPE.ByteString -> SPE.Block Word8 #-} +{-# SPECIALIZE convert :: SPE.Block Word8 -> SPE.ByteString #-} +#endif diff --git a/bundled/Data/ByteArray/Pack.hs b/bundled/Data/ByteArray/Pack.hs new file mode 100644 index 0000000..2271670 --- /dev/null +++ b/bundled/Data/ByteArray/Pack.hs @@ -0,0 +1,145 @@ +-- | +-- Module : Data.ByteArray.Pack +-- License : BSD-Style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Simple Byte Array packer +-- +-- Simple example: +-- +-- > > flip pack 20 $ putWord8 0x41 >> putByteString "BCD" >> putWord8 0x20 >> putStorable (42 :: Word32) +-- > Right (ABCD *\NUL\NUL\NUL") +-- +-- Original code from +-- generalized and adapted to run on 'memory', and spellchecked / tweaked. (2015-05) +-- Copyright (c) 2014 Nicolas DI PRIMA +-- +module Data.ByteArray.Pack + ( Packer + , Result(..) + , fill + , pack + -- * Operations + -- ** put + , putWord8 + , putWord16 + , putWord32 + , putStorable + , putBytes + , fillList + , fillUpWith + -- ** skip + , skip + , skipStorable + ) where + +import Data.Word +import Foreign.Ptr +import Foreign.Storable +import Data.Memory.Internal.Imports () +import Data.Memory.Internal.Compat +import Data.Memory.PtrMethods +import Data.ByteArray.Pack.Internal +import Data.ByteArray (ByteArray, ByteArrayAccess, MemView(..)) +import qualified Data.ByteArray as B + +-- | Fill a given sized buffer with the result of the Packer action +fill :: ByteArray byteArray => Int -> Packer a -> Either String byteArray +fill len packing = unsafeDoIO $ do + (val, out) <- B.allocRet len $ \ptr -> runPacker_ packing (MemView ptr len) + case val of + PackerMore _ (MemView _ r) + | r == 0 -> return $ Right out + | otherwise -> return $ Left ("remaining unpacked bytes " ++ show r ++ " at the end of buffer") + PackerFail err -> return $ Left err + +-- | Pack the given packer into the given bytestring +pack :: ByteArray byteArray => Packer a -> Int -> Either String byteArray +pack packing len = fill len packing +{-# DEPRECATED pack "use fill instead" #-} + +fillUpWithWord8' :: Word8 -> Packer () +fillUpWithWord8' w = Packer $ \(MemView ptr size) -> do + memSet ptr w size + return $ PackerMore () (MemView (ptr `plusPtr` size) 0) + +-- | Put a storable from the current position in the stream +putStorable :: Storable storable => storable -> Packer () +putStorable s = actionPacker (sizeOf s) (\ptr -> poke (castPtr ptr) s) + +-- | Put a Byte Array from the current position in the stream +-- +-- If the ByteArray is null, then do nothing +putBytes :: ByteArrayAccess ba => ba -> Packer () +putBytes bs + | neededLength == 0 = return () + | otherwise = + actionPacker neededLength $ \dstPtr -> B.withByteArray bs $ \srcPtr -> + memCopy dstPtr srcPtr neededLength + where + neededLength = B.length bs + +-- | Skip some bytes from the current position in the stream +skip :: Int -> Packer () +skip n = actionPacker n (\_ -> return ()) + +-- | Skip the size of a storable from the current position in the stream +skipStorable :: Storable storable => storable -> Packer () +skipStorable = skip . sizeOf + +-- | Fill up from the current position in the stream to the end +-- +-- It is equivalent to: +-- +-- > fillUpWith s == fillList (repeat s) +-- +fillUpWith :: Storable storable => storable -> Packer () +fillUpWith s = fillList $ repeat s +{-# RULES "fillUpWithWord8" forall s . fillUpWith s = fillUpWithWord8' s #-} +{-# NOINLINE fillUpWith #-} + +-- | Will put the given storable list from the current position in the stream +-- to the end. +-- +-- This function will fail with not enough storage if the given storable can't +-- be written (not enough space) +-- +-- Example: +-- +-- > > pack (fillList $ [1..] :: Word8) 9 +-- > "\1\2\3\4\5\6\7\8\9" +-- > > pack (fillList $ [1..] :: Word32) 4 +-- > "\1\0\0\0" +-- > > pack (fillList $ [1..] :: Word32) 64 +-- > .. <..succesful..> +-- > > pack (fillList $ [1..] :: Word32) 1 +-- > .. <.. not enough space ..> +-- > > pack (fillList $ [1..] :: Word32) 131 +-- > .. <.. not enough space ..> +-- +fillList :: Storable storable => [storable] -> Packer () +fillList [] = return () +fillList (x:xs) = putStorable x >> fillList xs + +------------------------------------------------------------------------------ +-- Common packer -- +------------------------------------------------------------------------------ + +-- | put Word8 in the current position in the stream +putWord8 :: Word8 -> Packer () +putWord8 = putStorable +{-# INLINE putWord8 #-} + +-- | put Word16 in the current position in the stream +-- /!\ use Host Endianness +putWord16 :: Word16 -> Packer () +putWord16 = putStorable +{-# INLINE putWord16 #-} + +-- | put Word32 in the current position in the stream +-- /!\ use Host Endianness +putWord32 :: Word32 -> Packer () +putWord32 = putStorable +{-# INLINE putWord32 #-} diff --git a/bundled/Data/ByteArray/Pack/Internal.hs b/bundled/Data/ByteArray/Pack/Internal.hs new file mode 100644 index 0000000..4645a82 --- /dev/null +++ b/bundled/Data/ByteArray/Pack/Internal.hs @@ -0,0 +1,88 @@ +-- | +-- Module : Data.ByteArray.Pack.Internal +-- License : BSD-Style +-- Copyright : Copyright © 2014 Nicolas DI PRIMA +-- +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Data.ByteArray.Pack.Internal + ( Result(..) + , Packer(..) + , actionPacker + , actionPackerWithRemain + ) where + +import Foreign.Ptr (Ptr) +import Data.ByteArray.MemView +import Data.Memory.Internal.Imports + +-- | Packing result: +-- +-- * PackerMore: the next state of Packing with an arbitrary value +-- * PackerFail: an error happened +data Result a = + PackerMore a MemView + | PackerFail String + deriving (Show) + +-- | Simple ByteArray Packer +newtype Packer a = Packer { runPacker_ :: MemView -> IO (Result a) } + +instance Functor Packer where + fmap = fmapPacker + +instance Applicative Packer where + pure = returnPacker + (<*>) = appendPacker + +instance Monad Packer where + return = pure + (>>=) = bindPacker + +fmapPacker :: (a -> b) -> Packer a -> Packer b +fmapPacker f p = Packer $ \cache -> do + rv <- runPacker_ p cache + return $ case rv of + PackerMore v cache' -> PackerMore (f v) cache' + PackerFail err -> PackerFail err +{-# INLINE fmapPacker #-} + +returnPacker :: a -> Packer a +returnPacker v = Packer $ \cache -> return $ PackerMore v cache +{-# INLINE returnPacker #-} + +bindPacker :: Packer a -> (a -> Packer b) -> Packer b +bindPacker p fp = Packer $ \cache -> do + rv <- runPacker_ p cache + case rv of + PackerMore v cache' -> runPacker_ (fp v) cache' + PackerFail err -> return $ PackerFail err +{-# INLINE bindPacker #-} + +appendPacker :: Packer (a -> b) -> Packer a -> Packer b +appendPacker p1f p2 = p1f >>= \p1 -> p2 >>= \v -> return (p1 v) +{-# INLINE appendPacker #-} + +-- | run a sized action +actionPacker :: Int -> (Ptr Word8 -> IO a) -> Packer a +actionPacker s action = Packer $ \m@(MemView ptr size) -> + case compare size s of + LT -> return $ PackerFail "Not enough space in destination" + _ -> do + v <- action ptr + return $ PackerMore v (m `memViewPlus` s) +{-# INLINE actionPacker #-} + +-- | run a sized action +actionPackerWithRemain :: Int -> (Ptr Word8 -> Int -> IO (Int, a)) -> Packer a +actionPackerWithRemain s action = Packer $ \m@(MemView ptr size) -> + case compare size s of + LT -> return $ PackerFail "Not enough space in destination" + _ -> do + (remain, v) <- action ptr size + return $ if remain > s + then PackerFail "remaining bytes higher than the destination's size" + else PackerMore v (m `memViewPlus` (s+remain)) +{-# INLINE actionPackerWithRemain #-} diff --git a/bundled/Data/ByteArray/Parse.hs b/bundled/Data/ByteArray/Parse.hs new file mode 100644 index 0000000..87f1fef --- /dev/null +++ b/bundled/Data/ByteArray/Parse.hs @@ -0,0 +1,258 @@ +-- | +-- Module : Data.ByteArray.Parse +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- A very simple bytearray parser related to Parsec and Attoparsec +-- +-- Simple example: +-- +-- > > parse ((,,) <$> take 2 <*> byte 0x20 <*> (bytes "abc" *> anyByte)) "xx abctest" +-- > ParseOK "est" ("xx", 116) +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE OverloadedStrings #-} +module Data.ByteArray.Parse + ( Parser + , Result(..) + -- * run the Parser + , parse + , parseFeed + -- * Parser methods + , hasMore + , byte + , anyByte + , bytes + , take + , takeWhile + , takeAll + , skip + , skipWhile + , skipAll + , takeStorable + ) where + +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Foreign.Storable (Storable, peek, sizeOf) +import Data.Word + +import Data.Memory.Internal.Imports +import Data.Memory.Internal.Compat +import Data.ByteArray.Types (ByteArrayAccess, ByteArray) +import qualified Data.ByteArray.Types as B +import qualified Data.ByteArray.Methods as B + +import Prelude hiding (take, takeWhile) + +-- | Simple parsing result, that represent respectively: +-- +-- * failure: with the error message +-- +-- * continuation: that need for more input data +-- +-- * success: the remaining unparsed data and the parser value +data Result byteArray a = + ParseFail String + | ParseMore (Maybe byteArray -> Result byteArray a) + | ParseOK byteArray a + +instance (Show ba, Show a) => Show (Result ba a) where + show (ParseFail err) = "ParseFailure: " ++ err + show (ParseMore _) = "ParseMore _" + show (ParseOK b a) = "ParseOK " ++ show a ++ " " ++ show b + +-- | The continuation of the current buffer, and the error string +type Failure byteArray r = byteArray -> String -> Result byteArray r + +-- | The continuation of the next buffer value, and the parsed value +type Success byteArray a r = byteArray -> a -> Result byteArray r + +-- | Simple ByteString parser structure +newtype Parser byteArray a = Parser + { runParser :: forall r . byteArray + -> Failure byteArray r + -> Success byteArray a r + -> Result byteArray r } + +instance Functor (Parser byteArray) where + fmap f p = Parser $ \buf err ok -> + runParser p buf err (\b a -> ok b (f a)) +instance Applicative (Parser byteArray) where + pure v = Parser $ \buf _ ok -> ok buf v + (<*>) d e = d >>= \b -> e >>= \a -> return (b a) +instance Monad (Parser byteArray) where +#if !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif + return = pure + m >>= k = Parser $ \buf err ok -> + runParser m buf err (\buf' a -> runParser (k a) buf' err ok) +instance Fail.MonadFail (Parser byteArray) where + fail errorMsg = Parser $ \buf err _ -> err buf ("Parser failed: " ++ errorMsg) +instance MonadPlus (Parser byteArray) where + mzero = fail "MonadPlus.mzero" + mplus f g = Parser $ \buf err ok -> + -- rewrite the err callback of @f to call @g + runParser f buf (\_ _ -> runParser g buf err ok) ok +instance Alternative (Parser byteArray) where + empty = fail "Alternative.empty" + (<|>) = mplus + +-- | Run a parser on an @initial byteArray. +-- +-- If the Parser need more data than available, the @feeder function +-- is automatically called and fed to the More continuation. +parseFeed :: (ByteArrayAccess byteArray, Monad m) + => m (Maybe byteArray) + -> Parser byteArray a + -> byteArray + -> m (Result byteArray a) +parseFeed feeder p initial = loop $ parse p initial + where loop (ParseMore k) = feeder >>= (loop . k) + loop r = return r + +-- | Run a Parser on a ByteString and return a 'Result' +parse :: ByteArrayAccess byteArray + => Parser byteArray a -> byteArray -> Result byteArray a +parse p s = runParser p s (\_ msg -> ParseFail msg) (\b a -> ParseOK b a) + +------------------------------------------------------------ + +-- When needing more data, getMore append the next data +-- to the current buffer. if no further data, then +-- the err callback is called. +getMore :: ByteArray byteArray => Parser byteArray () +getMore = Parser $ \buf err ok -> ParseMore $ \nextChunk -> + case nextChunk of + Nothing -> err buf "EOL: need more data" + Just nc + | B.null nc -> runParser getMore buf err ok + | otherwise -> ok (B.append buf nc) () + +-- Only used by takeAll, which accumulate all the remaining data +-- until ParseMore is fed a Nothing value. +-- +-- getAll cannot fail. +getAll :: ByteArray byteArray => Parser byteArray () +getAll = Parser $ \buf err ok -> ParseMore $ \nextChunk -> + case nextChunk of + Nothing -> ok buf () + Just nc -> runParser getAll (B.append buf nc) err ok + +-- Only used by skipAll, which flush all the remaining data +-- until ParseMore is fed a Nothing value. +-- +-- flushAll cannot fail. +flushAll :: ByteArray byteArray => Parser byteArray () +flushAll = Parser $ \buf err ok -> ParseMore $ \nextChunk -> + case nextChunk of + Nothing -> ok buf () + Just _ -> runParser flushAll B.empty err ok + +------------------------------------------------------------ +hasMore :: ByteArray byteArray => Parser byteArray Bool +hasMore = Parser $ \buf err ok -> + if B.null buf + then ParseMore $ \nextChunk -> + case nextChunk of + Nothing -> ok buf False + Just nc -> runParser hasMore nc err ok + else ok buf True + +-- | Get the next byte from the parser +anyByte :: ByteArray byteArray => Parser byteArray Word8 +anyByte = Parser $ \buf err ok -> + case B.uncons buf of + Nothing -> runParser (getMore >> anyByte) buf err ok + Just (c1,b2) -> ok b2 c1 + +-- | Parse a specific byte at current position +-- +-- if the byte is different than the expected on, +-- this parser will raise a failure. +byte :: ByteArray byteArray => Word8 -> Parser byteArray () +byte w = Parser $ \buf err ok -> + case B.uncons buf of + Nothing -> runParser (getMore >> byte w) buf err ok + Just (c1,b2) | c1 == w -> ok b2 () + | otherwise -> err buf ("byte " ++ show w ++ " : failed : got " ++ show c1) + +-- | Parse a sequence of bytes from current position +-- +-- if the following bytes don't match the expected +-- bytestring completely, the parser will raise a failure +bytes :: (Show ba, Eq ba, ByteArray ba) => ba -> Parser ba () +bytes allExpected = consumeEq allExpected + where errMsg = "bytes " ++ show allExpected ++ " : failed" + + -- partially consume as much as possible or raise an error. + consumeEq expected = Parser $ \actual err ok -> + let eLen = B.length expected in + if B.length actual >= eLen + then -- enough data for doing a full match + let (aMatch,aRem) = B.splitAt eLen actual + in if aMatch == expected + then ok aRem () + else err actual errMsg + else -- not enough data, match as much as we have, and then recurse. + let (eMatch, eRem) = B.splitAt (B.length actual) expected + in if actual == eMatch + then runParser (getMore >> consumeEq eRem) B.empty err ok + else err actual errMsg + +------------------------------------------------------------ + +-- | Take a storable from the current position in the stream +takeStorable :: (ByteArray byteArray, Storable d) + => Parser byteArray d +takeStorable = anyStorable undefined + where + anyStorable :: ByteArray byteArray => Storable d => d -> Parser byteArray d + anyStorable a = do + buf <- take (sizeOf a) + return $ unsafeDoIO $ B.withByteArray buf $ \ptr -> peek ptr + +-- | Take @n bytes from the current position in the stream +take :: ByteArray byteArray => Int -> Parser byteArray byteArray +take n = Parser $ \buf err ok -> + if B.length buf >= n + then let (b1,b2) = B.splitAt n buf in ok b2 b1 + else runParser (getMore >> take n) buf err ok + +-- | Take bytes while the @predicate hold from the current position in the stream +takeWhile :: ByteArray byteArray => (Word8 -> Bool) -> Parser byteArray byteArray +takeWhile predicate = Parser $ \buf err ok -> + let (b1, b2) = B.span predicate buf + in if B.null b2 + then runParser (getMore >> takeWhile predicate) buf err ok + else ok b2 b1 + +-- | Take the remaining bytes from the current position in the stream +takeAll :: ByteArray byteArray => Parser byteArray byteArray +takeAll = Parser $ \buf err ok -> + runParser (getAll >> returnBuffer) buf err ok + where + returnBuffer = Parser $ \buf _ ok -> ok B.empty buf + +-- | Skip @n bytes from the current position in the stream +skip :: ByteArray byteArray => Int -> Parser byteArray () +skip n = Parser $ \buf err ok -> + if B.length buf >= n + then ok (B.drop n buf) () + else runParser (getMore >> skip (n - B.length buf)) B.empty err ok + +-- | Skip bytes while the @predicate hold from the current position in the stream +skipWhile :: ByteArray byteArray => (Word8 -> Bool) -> Parser byteArray () +skipWhile p = Parser $ \buf err ok -> + let (_, b2) = B.span p buf + in if B.null b2 + then runParser (getMore >> skipWhile p) B.empty err ok + else ok b2 () + +-- | Skip all the remaining bytes from the current position in the stream +skipAll :: ByteArray byteArray => Parser byteArray () +skipAll = Parser $ \buf err ok -> runParser flushAll buf err ok diff --git a/bundled/Data/ByteArray/ScrubbedBytes.hs b/bundled/Data/ByteArray/ScrubbedBytes.hs new file mode 100644 index 0000000..75d2321 --- /dev/null +++ b/bundled/Data/ByteArray/ScrubbedBytes.hs @@ -0,0 +1,205 @@ +-- | +-- Module : Data.ByteArray.ScrubbedBytes +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : Stable +-- Portability : GHC +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Data.ByteArray.ScrubbedBytes + ( ScrubbedBytes + ) where + +import GHC.Types +import GHC.Prim +import GHC.Ptr +import GHC.Word +#if MIN_VERSION_base(4,15,0) +import GHC.Exts (unsafeCoerce#) +#endif +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup +import Data.Foldable (toList) +#else +import Data.Monoid +#endif +import Data.String (IsString(..)) +import Data.Typeable +import Data.Memory.PtrMethods +import Data.Memory.Internal.CompatPrim +import Data.Memory.Internal.Compat (unsafeDoIO) +import Data.Memory.Internal.Imports +import Data.ByteArray.Types +import Foreign.Storable +#ifdef MIN_VERSION_basement +import Basement.NormalForm +#endif + +-- | ScrubbedBytes is a memory chunk which have the properties of: +-- +-- * Being scrubbed after its goes out of scope. +-- +-- * A Show instance that doesn't actually show any content +-- +-- * A Eq instance that is constant time +-- +data ScrubbedBytes = ScrubbedBytes (MutableByteArray# RealWorld) + deriving (Typeable) + +instance Show ScrubbedBytes where + show _ = "" + +instance Eq ScrubbedBytes where + (==) = scrubbedBytesEq +instance Ord ScrubbedBytes where + compare = scrubbedBytesCompare +#if MIN_VERSION_base(4,9,0) +instance Semigroup ScrubbedBytes where + b1 <> b2 = unsafeDoIO $ scrubbedBytesAppend b1 b2 + sconcat = unsafeDoIO . scrubbedBytesConcat . toList +#endif +instance Monoid ScrubbedBytes where + mempty = unsafeDoIO (newScrubbedBytes 0) +#if !(MIN_VERSION_base(4,11,0)) + mappend b1 b2 = unsafeDoIO $ scrubbedBytesAppend b1 b2 + mconcat = unsafeDoIO . scrubbedBytesConcat +#endif +instance NFData ScrubbedBytes where + rnf b = b `seq` () +#ifdef MIN_VERSION_basement +instance NormalForm ScrubbedBytes where + toNormalForm b = b `seq` () +#endif +instance IsString ScrubbedBytes where + fromString = scrubbedFromChar8 + +instance ByteArrayAccess ScrubbedBytes where + length = sizeofScrubbedBytes + withByteArray = withPtr + +instance ByteArray ScrubbedBytes where + allocRet = scrubbedBytesAllocRet + +newScrubbedBytes :: Int -> IO ScrubbedBytes +newScrubbedBytes (I# sz) + | booleanPrim (sz <# 0#) = error "ScrubbedBytes: size must be >= 0" + | booleanPrim (sz ==# 0#) = IO $ \s -> + case newAlignedPinnedByteArray# 0# 8# s of + (# s2, mba #) -> (# s2, ScrubbedBytes mba #) + | otherwise = IO $ \s -> + case newAlignedPinnedByteArray# sz 8# s of + (# s1, mbarr #) -> + let !scrubber = getScrubber (byteArrayContents# (unsafeCoerce# mbarr)) + !mba = ScrubbedBytes mbarr + in case mkWeak# mbarr () (finalize scrubber mba) s1 of + (# s2, _ #) -> (# s2, mba #) + where + getScrubber :: Addr# -> State# RealWorld -> State# RealWorld + getScrubber addr s = + let IO scrubBytes = memSet (Ptr addr) 0 (I# sz) + in case scrubBytes s of + (# s', _ #) -> s' + +#if __GLASGOW_HASKELL__ >= 800 + finalize :: (State# RealWorld -> State# RealWorld) -> ScrubbedBytes -> State# RealWorld -> (# State# RealWorld, () #) + finalize scrubber mba@(ScrubbedBytes _) = \s1 -> + case scrubber s1 of + s2 -> case touch# mba s2 of + s3 -> (# s3, () #) +#else + finalize :: (State# RealWorld -> State# RealWorld) -> ScrubbedBytes -> IO () + finalize scrubber mba@(ScrubbedBytes _) = IO $ \s1 -> do + case scrubber s1 of + s2 -> case touch# mba s2 of + s3 -> (# s3, () #) +#endif + +scrubbedBytesAllocRet :: Int -> (Ptr p -> IO a) -> IO (a, ScrubbedBytes) +scrubbedBytesAllocRet sz f = do + ba <- newScrubbedBytes sz + r <- withPtr ba f + return (r, ba) + +scrubbedBytesAlloc :: Int -> (Ptr p -> IO ()) -> IO ScrubbedBytes +scrubbedBytesAlloc sz f = do + ba <- newScrubbedBytes sz + withPtr ba f + return ba + +scrubbedBytesConcat :: [ScrubbedBytes] -> IO ScrubbedBytes +scrubbedBytesConcat l = scrubbedBytesAlloc retLen (copy l) + where + retLen = sum $ map sizeofScrubbedBytes l + + copy [] _ = return () + copy (x:xs) dst = do + withPtr x $ \src -> memCopy dst src chunkLen + copy xs (dst `plusPtr` chunkLen) + where + chunkLen = sizeofScrubbedBytes x + +scrubbedBytesAppend :: ScrubbedBytes -> ScrubbedBytes -> IO ScrubbedBytes +scrubbedBytesAppend b1 b2 = scrubbedBytesAlloc retLen $ \dst -> do + withPtr b1 $ \s1 -> memCopy dst s1 len1 + withPtr b2 $ \s2 -> memCopy (dst `plusPtr` len1) s2 len2 + where + len1 = sizeofScrubbedBytes b1 + len2 = sizeofScrubbedBytes b2 + retLen = len1 + len2 + + +sizeofScrubbedBytes :: ScrubbedBytes -> Int +sizeofScrubbedBytes (ScrubbedBytes mba) = I# (sizeofMutableByteArray# mba) + +withPtr :: ScrubbedBytes -> (Ptr p -> IO a) -> IO a +withPtr b@(ScrubbedBytes mba) f = do + a <- f (Ptr (byteArrayContents# (unsafeCoerce# mba))) + touchScrubbedBytes b + return a + +touchScrubbedBytes :: ScrubbedBytes -> IO () +touchScrubbedBytes (ScrubbedBytes mba) = IO $ \s -> case touch# mba s of s' -> (# s', () #) + +scrubbedBytesEq :: ScrubbedBytes -> ScrubbedBytes -> Bool +scrubbedBytesEq a b + | l1 /= l2 = False + | otherwise = unsafeDoIO $ withPtr a $ \p1 -> withPtr b $ \p2 -> memConstEqual p1 p2 l1 + where + l1 = sizeofScrubbedBytes a + l2 = sizeofScrubbedBytes b + +scrubbedBytesCompare :: ScrubbedBytes -> ScrubbedBytes -> Ordering +scrubbedBytesCompare b1@(ScrubbedBytes m1) b2@(ScrubbedBytes m2) = unsafeDoIO $ loop 0 + where + !l1 = sizeofScrubbedBytes b1 + !l2 = sizeofScrubbedBytes b2 + !len = min l1 l2 + + loop !i + | i == len = + if l1 == l2 + then pure EQ + else if l1 > l2 then pure GT + else pure LT + | otherwise = do + e1 <- read8 m1 i + e2 <- read8 m2 i + if e1 == e2 + then loop (i+1) + else if e1 < e2 then pure LT + else pure GT + + read8 m (I# i) = IO $ \s -> case readWord8Array# m i s of + (# s2, e #) -> (# s2, W8# e #) + +scrubbedFromChar8 :: [Char] -> ScrubbedBytes +scrubbedFromChar8 l = unsafeDoIO $ scrubbedBytesAlloc len (fill l) + where + len = Prelude.length l + fill :: [Char] -> Ptr Word8 -> IO () + fill [] _ = return () + fill (x:xs) !p = poke p (fromIntegral $ fromEnum x) >> fill xs (p `plusPtr` 1) diff --git a/bundled/Data/ByteArray/Sized.hs b/bundled/Data/ByteArray/Sized.hs new file mode 100644 index 0000000..a3a70a5 --- /dev/null +++ b/bundled/Data/ByteArray/Sized.hs @@ -0,0 +1,398 @@ +-- | +-- Module : Data.ByteArray.Sized +-- License : BSD-style +-- Maintainer : Nicolas Di Prima +-- Stability : stable +-- Portability : Good +-- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE NoStarIsType #-} +#endif + +module Data.ByteArray.Sized + ( ByteArrayN(..) + , SizedByteArray + , unSizedByteArray + , sizedByteArray + , unsafeSizedByteArray + + , -- * ByteArrayN operators + alloc + , create + , allocAndFreeze + , unsafeCreate + , inlineUnsafeCreate + , empty + , pack + , unpack + , cons + , snoc + , xor + , index + , splitAt + , take + , drop + , append + , copy + , copyRet + , copyAndFreeze + , replicate + , zero + , convert + , fromByteArrayAccess + , unsafeFromByteArrayAccess + ) where + +import Basement.Imports +import Basement.NormalForm +import Basement.Nat +import Basement.Numerical.Additive ((+)) +import Basement.Numerical.Subtractive ((-)) + +import Basement.Sized.List (ListN, unListN, toListN) + +import Foreign.Storable +import Foreign.Ptr +import Data.Maybe (fromMaybe) + +import Data.Memory.Internal.Compat +import Data.Memory.PtrMethods + +import Data.Proxy (Proxy(..)) + +import Data.ByteArray.Types (ByteArrayAccess(..), ByteArray) +import qualified Data.ByteArray.Types as ByteArray (allocRet) + +#if MIN_VERSION_basement(0,0,7) +import Basement.BlockN (BlockN) +import qualified Basement.BlockN as BlockN +import qualified Basement.PrimType as Base +import Basement.Types.OffsetSize (Countable) +#endif + +-- | Type class to emulate exactly the behaviour of 'ByteArray' but with +-- a known length at compile time +-- +class (ByteArrayAccess c, KnownNat n) => ByteArrayN (n :: Nat) c | c -> n where + -- | just like 'allocRet' but with the size at the type level + allocRet :: forall p a + . Proxy n + -> (Ptr p -> IO a) + -> IO (a, c) + +-- | Wrapper around any collection type with the size as type parameter +-- +newtype SizedByteArray (n :: Nat) ba = SizedByteArray { unSizedByteArray :: ba } + deriving (Eq, Show, Typeable, Ord, NormalForm) + +-- | create a 'SizedByteArray' from the given 'ByteArrayAccess' if the +-- size is the same as the target size. +-- +sizedByteArray :: forall n ba . (KnownNat n, ByteArrayAccess ba) + => ba + -> Maybe (SizedByteArray n ba) +sizedByteArray ba + | length ba == n = Just $ SizedByteArray ba + | otherwise = Nothing + where + n = fromInteger $ natVal (Proxy @n) + +-- | just like the 'sizedByteArray' function but throw an exception if +-- the size is invalid. +unsafeSizedByteArray :: forall n ba . (ByteArrayAccess ba, KnownNat n) => ba -> SizedByteArray n ba +unsafeSizedByteArray = fromMaybe (error "The size is invalid") . sizedByteArray + +instance (ByteArrayAccess ba, KnownNat n) => ByteArrayAccess (SizedByteArray n ba) where + length _ = fromInteger $ natVal (Proxy @n) + withByteArray (SizedByteArray ba) = withByteArray ba + +instance (KnownNat n, ByteArray ba) => ByteArrayN n (SizedByteArray n ba) where + allocRet p f = do + (a, ba) <- ByteArray.allocRet n f + pure (a, SizedByteArray ba) + where + n = fromInteger $ natVal p + +#if MIN_VERSION_basement(0,0,7) +instance ( ByteArrayAccess (BlockN n ty) + , PrimType ty + , KnownNat n + , Countable ty n + , KnownNat nbytes + , nbytes ~ (Base.PrimSize ty * n) + ) => ByteArrayN nbytes (BlockN n ty) where + allocRet _ f = do + mba <- BlockN.new @n + a <- BlockN.withMutablePtrHint True False mba (f . castPtr) + ba <- BlockN.freeze mba + return (a, ba) +#endif + + +-- | Allocate a new bytearray of specific size, and run the initializer on this memory +alloc :: forall n ba p . (ByteArrayN n ba, KnownNat n) + => (Ptr p -> IO ()) + -> IO ba +alloc f = snd <$> allocRet (Proxy @n) f + +-- | Allocate a new bytearray of specific size, and run the initializer on this memory +create :: forall n ba p . (ByteArrayN n ba, KnownNat n) + => (Ptr p -> IO ()) + -> IO ba +create = alloc @n +{-# NOINLINE create #-} + +-- | similar to 'allocN' but hide the allocation and initializer in a pure context +allocAndFreeze :: forall n ba p . (ByteArrayN n ba, KnownNat n) + => (Ptr p -> IO ()) -> ba +allocAndFreeze f = unsafeDoIO (alloc @n f) +{-# NOINLINE allocAndFreeze #-} + +-- | similar to 'createN' but hide the allocation and initializer in a pure context +unsafeCreate :: forall n ba p . (ByteArrayN n ba, KnownNat n) + => (Ptr p -> IO ()) -> ba +unsafeCreate f = unsafeDoIO (alloc @n f) +{-# NOINLINE unsafeCreate #-} + +inlineUnsafeCreate :: forall n ba p . (ByteArrayN n ba, KnownNat n) + => (Ptr p -> IO ()) -> ba +inlineUnsafeCreate f = unsafeDoIO (alloc @n f) +{-# INLINE inlineUnsafeCreate #-} + +-- | Create an empty byte array +empty :: forall ba . ByteArrayN 0 ba => ba +empty = unsafeDoIO (alloc @0 $ \_ -> return ()) + +-- | Pack a list of bytes into a bytearray +pack :: forall n ba . (ByteArrayN n ba, KnownNat n) => ListN n Word8 -> ba +pack l = inlineUnsafeCreate @n (fill $ unListN l) + where fill [] _ = return () + fill (x:xs) !p = poke p x >> fill xs (p `plusPtr` 1) + {-# INLINE fill #-} +{-# NOINLINE pack #-} + +-- | Un-pack a bytearray into a list of bytes +unpack :: forall n ba + . (ByteArrayN n ba, KnownNat n, NatWithinBound Int n, ByteArrayAccess ba) + => ba -> ListN n Word8 +unpack bs = fromMaybe (error "the impossible appened") $ toListN @n $ loop 0 + where !len = length bs + loop i + | i == len = [] + | otherwise = + let !v = unsafeDoIO $ withByteArray bs (`peekByteOff` i) + in v : loop (i+1) + +-- | prepend a single byte to a byte array +cons :: forall ni no bi bo + . ( ByteArrayN ni bi, ByteArrayN no bo, ByteArrayAccess bi + , KnownNat ni, KnownNat no + , (ni + 1) ~ no + ) + => Word8 -> bi -> bo +cons b ba = unsafeCreate @no $ \d -> withByteArray ba $ \s -> do + pokeByteOff d 0 b + memCopy (d `plusPtr` 1) s len + where + !len = fromInteger $ natVal (Proxy @ni) + +-- | append a single byte to a byte array +snoc :: forall bi bo ni no + . ( ByteArrayN ni bi, ByteArrayN no bo, ByteArrayAccess bi + , KnownNat ni, KnownNat no + , (ni + 1) ~ no + ) + => bi -> Word8 -> bo +snoc ba b = unsafeCreate @no $ \d -> withByteArray ba $ \s -> do + memCopy d s len + pokeByteOff d len b + where + !len = fromInteger $ natVal (Proxy @ni) + +-- | Create a xor of bytes between a and b. +-- +-- the returns byte array is the size of the smallest input. +xor :: forall n a b c + . ( ByteArrayN n a, ByteArrayN n b, ByteArrayN n c + , ByteArrayAccess a, ByteArrayAccess b + , KnownNat n + ) + => a -> b -> c +xor a b = + unsafeCreate @n $ \pc -> + withByteArray a $ \pa -> + withByteArray b $ \pb -> + memXor pc pa pb n + where + n = fromInteger (natVal (Proxy @n)) + +-- | return a specific byte indexed by a number from 0 in a bytearray +-- +-- unsafe, no bound checking are done +index :: forall n na ba + . ( ByteArrayN na ba, ByteArrayAccess ba + , KnownNat na, KnownNat n + , n <= na + ) + => ba -> Proxy n -> Word8 +index b pi = unsafeDoIO $ withByteArray b $ \p -> peek (p `plusPtr` i) + where + i = fromInteger $ natVal pi + +-- | Split a bytearray at a specific length in two bytearray +splitAt :: forall nblhs nbi nbrhs bi blhs brhs + . ( ByteArrayN nbi bi, ByteArrayN nblhs blhs, ByteArrayN nbrhs brhs + , ByteArrayAccess bi + , KnownNat nbi, KnownNat nblhs, KnownNat nbrhs + , nblhs <= nbi, (nbrhs + nblhs) ~ nbi + ) + => bi -> (blhs, brhs) +splitAt bs = unsafeDoIO $ + withByteArray bs $ \p -> do + b1 <- alloc @nblhs $ \r -> memCopy r p n + b2 <- alloc @nbrhs $ \r -> memCopy r (p `plusPtr` n) (len - n) + return (b1, b2) + where + n = fromInteger $ natVal (Proxy @nblhs) + len = length bs + +-- | Take the first @n@ byte of a bytearray +take :: forall nbo nbi bi bo + . ( ByteArrayN nbi bi, ByteArrayN nbo bo + , ByteArrayAccess bi + , KnownNat nbi, KnownNat nbo + , nbo <= nbi + ) + => bi -> bo +take bs = unsafeCreate @nbo $ \d -> withByteArray bs $ \s -> memCopy d s m + where + !m = min len n + !len = length bs + !n = fromInteger $ natVal (Proxy @nbo) + +-- | drop the first @n@ byte of a bytearray +drop :: forall n nbi nbo bi bo + . ( ByteArrayN nbi bi, ByteArrayN nbo bo + , ByteArrayAccess bi + , KnownNat n, KnownNat nbi, KnownNat nbo + , (nbo + n) ~ nbi + ) + => Proxy n -> bi -> bo +drop pn bs = unsafeCreate @nbo $ \d -> + withByteArray bs $ \s -> + memCopy d (s `plusPtr` ofs) nb + where + ofs = min len n + nb = len - ofs + len = length bs + n = fromInteger $ natVal pn + +-- | append one bytearray to the other +append :: forall nblhs nbrhs nbout blhs brhs bout + . ( ByteArrayN nblhs blhs, ByteArrayN nbrhs brhs, ByteArrayN nbout bout + , ByteArrayAccess blhs, ByteArrayAccess brhs + , KnownNat nblhs, KnownNat nbrhs, KnownNat nbout + , (nbrhs + nblhs) ~ nbout + ) + => blhs -> brhs -> bout +append blhs brhs = unsafeCreate @nbout $ \p -> + withByteArray blhs $ \plhs -> + withByteArray brhs $ \prhs -> do + memCopy p plhs (length blhs) + memCopy (p `plusPtr` length blhs) prhs (length brhs) + +-- | Duplicate a bytearray into another bytearray, and run an initializer on it +copy :: forall n bs1 bs2 p + . ( ByteArrayN n bs1, ByteArrayN n bs2 + , ByteArrayAccess bs1 + , KnownNat n + ) + => bs1 -> (Ptr p -> IO ()) -> IO bs2 +copy bs f = alloc @n $ \d -> do + withByteArray bs $ \s -> memCopy d s (length bs) + f (castPtr d) + +-- | Similar to 'copy' but also provide a way to return a value from the initializer +copyRet :: forall n bs1 bs2 p a + . ( ByteArrayN n bs1, ByteArrayN n bs2 + , ByteArrayAccess bs1 + , KnownNat n + ) + => bs1 -> (Ptr p -> IO a) -> IO (a, bs2) +copyRet bs f = + allocRet (Proxy @n) $ \d -> do + withByteArray bs $ \s -> memCopy d s (length bs) + f (castPtr d) + +-- | Similiar to 'copy' but expect the resulting bytearray in a pure context +copyAndFreeze :: forall n bs1 bs2 p + . ( ByteArrayN n bs1, ByteArrayN n bs2 + , ByteArrayAccess bs1 + , KnownNat n + ) + => bs1 -> (Ptr p -> IO ()) -> bs2 +copyAndFreeze bs f = + inlineUnsafeCreate @n $ \d -> do + copyByteArrayToPtr bs d + f (castPtr d) +{-# NOINLINE copyAndFreeze #-} + +-- | Create a bytearray of a specific size containing a repeated byte value +replicate :: forall n ba . (ByteArrayN n ba, KnownNat n) + => Word8 -> ba +replicate b = inlineUnsafeCreate @n $ \ptr -> memSet ptr b (fromInteger $ natVal $ Proxy @n) +{-# NOINLINE replicate #-} + +-- | Create a bytearray of a specific size initialized to 0 +zero :: forall n ba . (ByteArrayN n ba, KnownNat n) => ba +zero = unsafeCreate @n $ \ptr -> memSet ptr 0 (fromInteger $ natVal $ Proxy @n) +{-# NOINLINE zero #-} + +-- | Convert a bytearray to another type of bytearray +convert :: forall n bin bout + . ( ByteArrayN n bin, ByteArrayN n bout + , KnownNat n + ) + => bin -> bout +convert bs = inlineUnsafeCreate @n (copyByteArrayToPtr bs) + +-- | Convert a ByteArrayAccess to another type of bytearray +-- +-- This function returns nothing if the size is not compatible +fromByteArrayAccess :: forall n bin bout + . ( ByteArrayAccess bin, ByteArrayN n bout + , KnownNat n + ) + => bin -> Maybe bout +fromByteArrayAccess bs + | l == n = Just $ inlineUnsafeCreate @n (copyByteArrayToPtr bs) + | otherwise = Nothing + where + l = length bs + n = fromInteger $ natVal (Proxy @n) + +-- | Convert a ByteArrayAccess to another type of bytearray +unsafeFromByteArrayAccess :: forall n bin bout + . ( ByteArrayAccess bin, ByteArrayN n bout + , KnownNat n + ) + => bin -> bout +unsafeFromByteArrayAccess bs = case fromByteArrayAccess @n @bin @bout bs of + Nothing -> error "Invalid Size" + Just v -> v diff --git a/bundled/Data/ByteArray/Types.hs b/bundled/Data/ByteArray/Types.hs new file mode 100644 index 0000000..d53f88b --- /dev/null +++ b/bundled/Data/ByteArray/Types.hs @@ -0,0 +1,133 @@ +-- | +-- Module : Data.ByteArray.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.ByteArray.Types + ( ByteArrayAccess(..) + , ByteArray(..) + ) where + +import Foreign.Ptr +import Data.Monoid + +#ifdef WITH_BYTESTRING_SUPPORT +import qualified Data.ByteString as Bytestring (length) +import qualified Data.ByteString.Internal as Bytestring +import Foreign.ForeignPtr (withForeignPtr) +#endif + +import Data.Memory.PtrMethods (memCopy) + + +import Data.Proxy (Proxy(..)) +import Data.Word (Word8) + +import qualified Basement.Types.OffsetSize as Base +import qualified Basement.UArray as Base +import qualified Basement.String as Base (String, toBytes, Encoding(UTF8)) + +import qualified Basement.UArray.Mutable as BaseMutable (withMutablePtrHint) +import qualified Basement.Block as Block +import qualified Basement.Block.Mutable as Block + +import Basement.Nat +import qualified Basement.Sized.Block as BlockN + +import Prelude hiding (length) + +-- | Class to Access size properties and data of a ByteArray +class ByteArrayAccess ba where + -- | Return the length in bytes of a bytearray + length :: ba -> Int + -- | Allow to use using a pointer + withByteArray :: ba -> (Ptr p -> IO a) -> IO a + -- | Copy the data of a bytearray to a ptr + copyByteArrayToPtr :: ba -> Ptr p -> IO () + copyByteArrayToPtr a dst = withByteArray a $ \src -> memCopy (castPtr dst) src (length a) + +-- | Class to allocate new ByteArray of specific size +class (Eq ba, Ord ba, Monoid ba, ByteArrayAccess ba) => ByteArray ba where + -- | allocate `n` bytes and perform the given operation + allocRet :: Int + -- ^ number of bytes to allocate. i.e. might not match the + -- size of the given type `ba`. + -> (Ptr p -> IO a) + -> IO (a, ba) + +#ifdef WITH_BYTESTRING_SUPPORT +instance ByteArrayAccess Bytestring.ByteString where + length = Bytestring.length + withByteArray (Bytestring.PS fptr off _) f = withForeignPtr fptr $ \ptr -> f $! (ptr `plusPtr` off) + +instance ByteArray Bytestring.ByteString where + allocRet sz f = do + fptr <- Bytestring.mallocByteString sz + r <- withForeignPtr fptr (f . castPtr) + return (r, Bytestring.PS fptr 0 sz) +#endif + +#ifdef WITH_BASEMENT_SUPPORT + +baseBlockRecastW8 :: Base.PrimType ty => Block.Block ty -> Block.Block Word8 +baseBlockRecastW8 = Block.unsafeCast -- safe with Word8 destination + +instance Base.PrimType ty => ByteArrayAccess (Block.Block ty) where + length a = let Base.CountOf i = Block.length (baseBlockRecastW8 a) in i + withByteArray a f = Block.withPtr (baseBlockRecastW8 a) (f . castPtr) + copyByteArrayToPtr ba dst = do + mb <- Block.unsafeThaw (baseBlockRecastW8 ba) + Block.copyToPtr mb 0 (castPtr dst) (Block.length $ baseBlockRecastW8 ba) + +instance (KnownNat n, Base.PrimType ty, Base.Countable ty n) => ByteArrayAccess (BlockN.BlockN n ty) where + length a = let Base.CountOf i = BlockN.lengthBytes a in i + withByteArray a f = BlockN.withPtr a (f . castPtr) + copyByteArrayToPtr bna = copyByteArrayToPtr (BlockN.toBlock bna) + +baseUarrayRecastW8 :: Base.PrimType ty => Base.UArray ty -> Base.UArray Word8 +baseUarrayRecastW8 = Base.recast + +instance Base.PrimType ty => ByteArrayAccess (Base.UArray ty) where + length a = let Base.CountOf i = Base.length (baseUarrayRecastW8 a) in i + withByteArray a f = Base.withPtr (baseUarrayRecastW8 a) (f . castPtr) + copyByteArrayToPtr ba dst = Base.copyToPtr ba (castPtr dst) + +instance ByteArrayAccess Base.String where + length str = let Base.CountOf i = Base.length bytes in i + where + -- the Foundation's length return a number of elements not a number of + -- bytes. For @ByteArrayAccess@, because we are using an @Int@, we + -- didn't see that we were returning the wrong @CountOf@. + bytes = Base.toBytes Base.UTF8 str + withByteArray s f = withByteArray (Base.toBytes Base.UTF8 s) f + +instance (Ord ty, Base.PrimType ty) => ByteArray (Block.Block ty) where + allocRet sz f = do + mba <- Block.new $ sizeRecastBytes sz Proxy + a <- Block.withMutablePtrHint True False mba (f . castPtr) + ba <- Block.unsafeFreeze mba + return (a, ba) + +instance (Ord ty, Base.PrimType ty) => ByteArray (Base.UArray ty) where + allocRet sz f = do + mba <- Base.new $ sizeRecastBytes sz Proxy + a <- BaseMutable.withMutablePtrHint True False mba (f . castPtr) + ba <- Base.unsafeFreeze mba + return (a, ba) + +sizeRecastBytes :: Base.PrimType ty => Int -> Proxy ty -> Base.CountOf ty +sizeRecastBytes w p = Base.CountOf $ + let (q,r) = w `Prelude.quotRem` szTy + in q + (if r == 0 then 0 else 1) + where !(Base.CountOf szTy) = Base.primSizeInBytes p +{-# INLINE [1] sizeRecastBytes #-} + +#endif diff --git a/bundled/Data/ByteArray/View.hs b/bundled/Data/ByteArray/View.hs new file mode 100644 index 0000000..8eb0992 --- /dev/null +++ b/bundled/Data/ByteArray/View.hs @@ -0,0 +1,128 @@ +-- | +-- Module : Data.ByteArray.View +-- License : BSD-style +-- Maintainer : Nicolas DI PRIMA +-- Stability : stable +-- Portability : Good +-- +-- a View on a given ByteArrayAccess +-- + +module Data.ByteArray.View + ( View + , view + , takeView + , dropView + ) where + +import Data.ByteArray.Methods +import Data.ByteArray.Types +import Data.Memory.PtrMethods +import Data.Memory.Internal.Compat +import Foreign.Ptr (plusPtr) + +import Prelude hiding (length, take, drop) + +-- | a view on a given bytes +-- +-- Equality test in constant time +data View bytes = View + { viewOffset :: !Int + , viewSize :: !Int + , unView :: !bytes + } + +instance ByteArrayAccess bytes => Eq (View bytes) where + (==) = constEq + +instance ByteArrayAccess bytes => Ord (View bytes) where + compare v1 v2 = unsafeDoIO $ + withByteArray v1 $ \ptr1 -> + withByteArray v2 $ \ptr2 -> do + ret <- memCompare ptr1 ptr2 (min (viewSize v1) (viewSize v2)) + return $ case ret of + EQ | length v1 > length v2 -> GT + | length v1 < length v2 -> LT + | length v1 == length v2 -> EQ + _ -> ret + +instance ByteArrayAccess bytes => Show (View bytes) where + showsPrec p v r = showsPrec p (viewUnpackChars v []) r + +instance ByteArrayAccess bytes => ByteArrayAccess (View bytes) where + length = viewSize + withByteArray v f = withByteArray (unView v) $ \ptr -> f (ptr `plusPtr` (viewOffset v)) + +viewUnpackChars :: ByteArrayAccess bytes + => View bytes + -> String + -> String +viewUnpackChars v xs = chunkLoop 0 + where + len = length v + + chunkLoop :: Int -> [Char] + chunkLoop idx + | len == idx = [] + | (len - idx) > 63 = + bytesLoop idx (idx + 64) (chunkLoop (idx + 64)) + | otherwise = + bytesLoop idx (len - idx) xs + + bytesLoop :: Int -> Int -> [Char] -> [Char] + bytesLoop idx chunkLenM1 paramAcc = + loop (idx + chunkLenM1 - 1) paramAcc + where + loop i acc + | i == idx = (rChar i : acc) + | otherwise = loop (i - 1) (rChar i : acc) + + rChar :: Int -> Char + rChar idx = toEnum $ fromIntegral $ index v idx + +-- | create a view on a given bytearray +-- +-- This function update the offset and the size in order to guarantee: +-- +-- * offset >= 0 +-- * size >= 0 +-- * offset < length +-- * size =< length - offset +-- +view :: ByteArrayAccess bytes + => bytes -- ^ the byte array we put a view on + -> Int -- ^ the offset to start the byte array on + -> Int -- ^ the size of the view + -> View bytes +view b offset'' size'' = View offset size b + where + -- make sure offset is not negative + offset' :: Int + offset' = max offset'' 0 + + -- make sure the offset is not out of bound + offset :: Int + offset = min offset' (length b - 1) + + -- make sure length is not negative + size' :: Int + size' = max size'' 0 + + -- make sure the length is not out of the bound + size :: Int + size = min size' (length b - offset) + +-- | create a view from the given bytearray +takeView :: ByteArrayAccess bytes + => bytes -- ^ byte aray + -> Int -- ^ size of the view + -> View bytes +takeView b size = view b 0 size + +-- | create a view from the given byte array +-- starting after having dropped the fist n bytes +dropView :: ByteArrayAccess bytes + => bytes -- ^ byte array + -> Int -- ^ the number of bytes do dropped before creating the view + -> View bytes +dropView b offset = view b offset (length b - offset) diff --git a/bundled/Data/ByteString/Base32.hs b/bundled/Data/ByteString/Base32.hs new file mode 100644 index 0000000..02e9217 --- /dev/null +++ b/bundled/Data/ByteString/Base32.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} +-- | +-- Module : Data.ByteString.Base32 +-- Copyright : (c) 2019-2023 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains 'Data.ByteString.ByteString'-valued combinators for +-- implementing the RFC 4648 specification of the Base32 +-- encoding format. This includes padded and unpadded decoding variants, as well as +-- internal and external validation for canonicity. +-- +module Data.ByteString.Base32 +( -- * Encoding + encodeBase32 +, encodeBase32' +, encodeBase32Unpadded +, encodeBase32Unpadded' + -- * Decoding +, decodeBase32 +, decodeBase32Unpadded +, decodeBase32Padded +-- , decodeBase32Lenient + -- * Validation +, isBase32 +, isValidBase32 +) where + + +import qualified Data.ByteString as BS +import Data.ByteString.Internal (ByteString(..)) +import Data.ByteString.Base32.Internal +import Data.ByteString.Base32.Internal.Tables +import Data.Either (isRight) +import Data.Text (Text) +import qualified Data.Text.Encoding as T + +import System.IO.Unsafe (unsafeDupablePerformIO) + + +-- | Encode a 'ByteString' value as a Base32 'Text' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "KN2W4===" +-- +encodeBase32 :: ByteString -> Text +encodeBase32 = T.decodeUtf8 . encodeBase32' +{-# INLINE encodeBase32 #-} + +-- | Encode a 'ByteString' value as a Base32 'ByteString' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32' "Sun" +-- "KN2W4===" +-- +encodeBase32' :: ByteString -> ByteString +encodeBase32' = encodeBase32_ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# +{-# INLINE encodeBase32' #-} + +-- | Decode an arbitrarily padded Base32-encoded 'ByteString' value. If its length +-- is not a multiple of 8, then padding characters will be added to fill out the +-- input to a multiple of 8 for safe decoding, as Base32-encoded values are +-- optionally padded. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32 "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32 :: ByteString -> Either Text ByteString +decodeBase32 bs@(BS _ !l) + | l == 0 = Right bs + | r == 0 = unsafeDupablePerformIO $ decodeBase32_ stdDecodeTable bs + | r == 2 = unsafeDupablePerformIO $ decodeBase32_ stdDecodeTable (BS.append bs "======") + | r == 4 = validateLastNPads 2 bs $ decodeBase32_ stdDecodeTable (BS.append bs "====") + | r == 5 = validateLastNPads 3 bs $ decodeBase32_ stdDecodeTable (BS.append bs "===") + | r == 7 = validateLastNPads 5 bs $ decodeBase32_ stdDecodeTable (BS.append bs "=") + | otherwise = Left "Base32-encoded bytestring has invalid size" + where + !r = l `rem` 8 +{-# INLINE decodeBase32 #-} + +-- | Encode a 'ByteString' value as a Base32 'Text' value without padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded "Sun" +-- "KN2W4" +-- +encodeBase32Unpadded :: ByteString -> Text +encodeBase32Unpadded = T.decodeUtf8 . encodeBase32Unpadded' +{-# INLINE encodeBase32Unpadded #-} + +-- | Encode a 'ByteString' value as a Base32 'ByteString' value without padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded' "Sun" +-- "KN2W4" +-- +encodeBase32Unpadded' :: ByteString -> ByteString +encodeBase32Unpadded' = encodeBase32NoPad_ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# +{-# INLINE encodeBase32Unpadded' #-} + +-- | Decode an unpadded Base32-encoded 'ByteString' value. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "KN2W4===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32Unpadded :: ByteString -> Either Text ByteString +decodeBase32Unpadded bs@(BS _ !l) + | l == 0 = Right bs + | r == 0 = validateLastNPads 1 bs $ decodeBase32_ stdDecodeTable bs + | r == 2 = unsafeDupablePerformIO $ decodeBase32_ stdDecodeTable (BS.append bs "======") + | r == 4 = validateLastNPads 1 bs $ decodeBase32_ stdDecodeTable (BS.append bs "====") + | r == 5 = validateLastNPads 1 bs $ decodeBase32_ stdDecodeTable (BS.append bs "===") + | r == 7 = validateLastNPads 1 bs $ decodeBase32_ stdDecodeTable (BS.append bs "=") + | otherwise = Left "Base32-encoded bytestring has invalid size" + where + !r = l `rem` 8 +{-# INLINE decodeBase32Unpadded #-} + +-- | Decode a padded Base32-encoded 'ByteString' value. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "KN2W4" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: ByteString -> Either Text ByteString +decodeBase32Padded bs@(BS _ !l) + | l == 0 = Right bs + | r == 1 = Left "Base32-encoded bytestring has invalid size" + | r == 3 = Left "Base32-encoded bytestring has invalid size" + | r == 6 = Left "Base32-encoded bytestring has invalid size" + | r /= 0 = Left "Base32-encoded bytestring requires padding" + | otherwise = unsafeDupablePerformIO $ decodeBase32_ stdDecodeTable bs + where + !r = l `rem` 8 +{-# INLINE decodeBase32Padded #-} + +-- -- | Leniently decode an unpadded Base32-encoded 'ByteString' value. This function +-- -- will not generate parse errors. If input data contains padding chars, +-- -- then the input will be parsed up until the first pad character. +-- -- +-- -- __Note:__ This is not RFC 4648-compliant. +-- -- +-- decodeBase32Lenient :: ByteString -> ByteString +-- decodeBase32Lenient = decodeBase32Lenient_ decodeB32Table +-- {-# INLINE decodeBase32Lenient #-} + +-- | Tell whether a 'ByteString' value is encoded in padded or unpadded Base32 format +-- +-- === __Examples__: +-- +-- >>> isBase32 "KN2W4" +-- True +-- +-- >>> isBase32 "KN2W4===" +-- True +-- +-- >>> isBase32 "KN2W4==" +-- False +-- +isBase32 :: ByteString -> Bool +isBase32 bs = isValidBase32 bs && isRight (decodeBase32 bs) +{-# INLINE isBase32 #-} + +-- | Tell whether a 'ByteString' value is a valid Base32 format. +-- +-- This will not tell you whether or not this is a correct Base32 representation, +-- only that it conforms to the correct shape (including padding/size etc.). +-- To check whether it is a true Base32 encoded 'ByteString' value, use 'isBase32'. +-- +-- === __Examples__: +-- +-- >>> isValidBase32 "KN2W4" +-- True +-- +-- >>> isValidBase32 "KN2W4=" +-- False +-- +-- >>> isValidBase32 "KN2W4%" +-- False +-- +isValidBase32 :: ByteString -> Bool +isValidBase32 = validateBase32 "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567" +{-# INLINE isValidBase32 #-} diff --git a/bundled/Data/ByteString/Base32/Hex.hs b/bundled/Data/ByteString/Base32/Hex.hs new file mode 100644 index 0000000..4bb1cb9 --- /dev/null +++ b/bundled/Data/ByteString/Base32/Hex.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} +-- | +-- Module : Data.ByteString.Base32.Hex +-- Copyright : (c) 2019-2023 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains 'Data.ByteString.ByteString'-valued combinators for +-- implementing the RFC 4648 specification of the Base32hex +-- encoding format. This includes padded and unpadded decoding variants, as well as +-- internal and external validation for canonicity. +-- +module Data.ByteString.Base32.Hex +( -- * Encoding + encodeBase32 +, encodeBase32' +, encodeBase32Unpadded +, encodeBase32Unpadded' + -- * Decoding +, decodeBase32 +, decodeBase32Unpadded +, decodeBase32Padded +-- , decodeBase32Lenient + -- * Validation +, isBase32Hex +, isValidBase32Hex +) where + + +import qualified Data.ByteString as BS +import Data.ByteString.Internal (ByteString(..)) +import Data.ByteString.Base32.Internal +import Data.ByteString.Base32.Internal.Tables +import Data.Either (isRight) +import Data.Text (Text) +import qualified Data.Text.Encoding as T + +import System.IO.Unsafe (unsafeDupablePerformIO) + + +-- | Encode a 'ByteString' value as a Base32hex 'Text' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "ADQMS===" +-- +encodeBase32 :: ByteString -> Text +encodeBase32 = T.decodeUtf8 . encodeBase32' +{-# INLINE encodeBase32 #-} + +-- | Encode a 'ByteString' value as a Base32hex 'ByteString' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32' "Sun" +-- "ADQMS===" +-- +encodeBase32' :: ByteString -> ByteString +encodeBase32' = encodeBase32_ "0123456789ABCDEFGHIJKLMNOPQRSTUV"# +{-# INLINE encodeBase32' #-} + +-- | Decode an arbitrarily padded Base32hex-encoded 'ByteString' value. If its length +-- is not a multiple of 8, then padding characters will be added to fill out the +-- input to a multiple of 8 for safe decoding, as Base32hex-encoded values are +-- optionally padded. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32 "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQM===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32 :: ByteString -> Either Text ByteString +decodeBase32 bs@(BS _ !l) + | l == 0 = Right bs + | r == 0 = unsafeDupablePerformIO $ decodeBase32_ hexDecodeTable bs + | r == 2 = unsafeDupablePerformIO $ decodeBase32_ hexDecodeTable (BS.append bs "======") + | r == 4 = validateLastNPads 2 bs $ decodeBase32_ hexDecodeTable (BS.append bs "====") + | r == 5 = validateLastNPads 3 bs $ decodeBase32_ hexDecodeTable (BS.append bs "===") + | r == 7 = validateLastNPads 5 bs $ decodeBase32_ hexDecodeTable (BS.append bs "=") + | otherwise = Left "Base32-encoded bytestring has invalid size" + where + !r = l `rem` 8 +{-# INLINE decodeBase32 #-} + +-- | Encode a 'ByteString' value as a Base32hex 'Text' value without padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded' "Sun" +-- "ADQMS" +-- +encodeBase32Unpadded :: ByteString -> Text +encodeBase32Unpadded = T.decodeUtf8 . encodeBase32Unpadded' +{-# INLINE encodeBase32Unpadded #-} + +-- | Encode a 'ByteString' value as a Base32hex 'ByteString' value without padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded' "Sun" +-- "ADQMS" +-- +encodeBase32Unpadded' :: ByteString -> ByteString +encodeBase32Unpadded' = encodeBase32NoPad_ "0123456789ABCDEFGHIJKLMNOPQRSTUV"# +{-# INLINE encodeBase32Unpadded' #-} + +-- | Decode an unpadded Base32hex-encoded 'ByteString' value. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32Unpadded :: ByteString -> Either Text ByteString +decodeBase32Unpadded bs@(BS _ !l) + | l == 0 = Right bs + | r == 0 = validateLastNPads 1 bs $ decodeBase32_ hexDecodeTable bs + | r == 2 = unsafeDupablePerformIO $ decodeBase32_ hexDecodeTable (BS.append bs "======") + | r == 4 = validateLastNPads 1 bs $ decodeBase32_ hexDecodeTable (BS.append bs "====") + | r == 5 = validateLastNPads 1 bs $ decodeBase32_ hexDecodeTable (BS.append bs "===") + | r == 7 = validateLastNPads 1 bs $ decodeBase32_ hexDecodeTable (BS.append bs "=") + | otherwise = Left "Base32-encoded bytestring has invalid size" + where + !r = l `rem` 8 +{-# INLINE decodeBase32Unpadded #-} + +-- | Decode a padded Base32hex-encoded 'ByteString' value. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "ADQMS" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: ByteString -> Either Text ByteString +decodeBase32Padded bs@(BS _ !l) + | l == 0 = Right bs + | r == 1 = Left "Base32-encoded bytestring has invalid size" + | r == 3 = Left "Base32-encoded bytestring has invalid size" + | r == 6 = Left "Base32-encoded bytestring has invalid size" + | r /= 0 = Left "Base32-encoded bytestring requires padding" + | otherwise = unsafeDupablePerformIO $ decodeBase32_ hexDecodeTable bs + where + !r = l `rem` 8 +{-# INLINE decodeBase32Padded #-} + +-- | Tell whether a 'ByteString' value is encoded in padded or unpadded Base32hex format +-- +-- === __Examples__: +-- +-- >>> isBase32Hex "ADQMS" +-- True +-- +-- >>> isBase32Hex "ADQMS===" +-- True +-- +-- >>> isBase32Hex "ADQMS==" +-- False +-- +isBase32Hex :: ByteString -> Bool +isBase32Hex bs = isValidBase32Hex bs && isRight (decodeBase32 bs) +{-# INLINE isBase32Hex #-} + +-- | Tell whether a 'ByteString' value is a valid Base32hex format. +-- +-- This will not tell you whether or not this is a correct Base32hex representation, +-- only that it conforms to the correct shape (including padding/size etc.). +-- To check whether it is a true Base32hex encoded 'ByteString' value, use 'isBase32'. +-- +-- === __Examples__: +-- +-- >>> isValidBase32Hex "ADQMS" +-- True +-- +-- >>> isValidBase32Hex "ADQMS=" +-- False +-- +-- >>> isValidBase32Hex "ADQMS%" +-- False +-- +isValidBase32Hex :: ByteString -> Bool +isValidBase32Hex = validateBase32 "0123456789ABCDEFGHIJKLMNOPQRSTUV" +{-# INLINE isValidBase32Hex #-} diff --git a/bundled/Data/ByteString/Base32/Internal.hs b/bundled/Data/ByteString/Base32/Internal.hs new file mode 100644 index 0000000..3e3c7e2 --- /dev/null +++ b/bundled/Data/ByteString/Base32/Internal.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Data.ByteString.Base32.Internal +-- Copyright : (c) 2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- Internal module defining the encoding and decoding +-- processes and tables. +-- +module Data.ByteString.Base32.Internal +( encodeBase32_ +, encodeBase32NoPad_ +, decodeBase32_ +, validateBase32 +, validateLastNPads +) where + + +import qualified Data.ByteString as BS +import Data.ByteString.Internal +import Data.ByteString.Base32.Internal.Head +import Data.Text (Text) + +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Storable + +import GHC.Word + +import System.IO.Unsafe + +-- -------------------------------------------------------------------------- -- +-- Validating Base32 + +-- | Validate a base32-encoded bytestring against some alphabet. +-- +validateBase32 :: ByteString -> ByteString -> Bool +validateBase32 !alphabet bs@(BS _ l) + | l == 0 = True + | r == 0 = f bs + | r == 2 = f (BS.append bs "======") + | r == 4 = f (BS.append bs "====") + | r == 5 = f (BS.append bs "===") + | r == 7 = f (BS.append bs "=") + | otherwise = False + where + r = l `rem` 8 + + f (BS fp l') = accursedUnutterablePerformIO $ withForeignPtr fp $ \p -> + go p (plusPtr p l') + + go !p !end + | p == end = return True + | otherwise = do + w <- peek p + + let check a + | a == 0x3d, plusPtr p 1 == end = True + | a == 0x3d, plusPtr p 2 == end = True + | a == 0x3d, plusPtr p 3 == end = True + | a == 0x3d, plusPtr p 4 == end = True + | a == 0x3d, plusPtr p 5 == end = True + | a == 0x3d, plusPtr p 6 == end = True + | a == 0x3d = False + | otherwise = BS.elem a alphabet + + if check w then go (plusPtr p 1) end else return False +{-# INLINE validateBase32 #-} + +-- | This function checks that the last N-chars of a bytestring are '=' +-- and, if true, fails with a message or completes some io action. +-- +-- This is necessary to check when decoding permissively (i.e. filling in padding chars). +-- Consider the following 8 cases of a string of length l: +-- +-- - @l = 0 mod 8@: No pad chars are added, since the input is assumed to be good. +-- - @l = 1 mod 8@: Never an admissible length in base32 +-- - @l = 2 mod 8@: 6 padding chars are added. If padding chars are present in the string, they will fail as to decode as final quanta +-- - @l = 3 mod 8@: Never an admissible length in base32 +-- - @l = 4 mod 8@: 4 padding chars are added. If 2 padding chars are present in the string this can be "completed" in the sense that +-- it now acts like a string `l == 2 mod 8` with 6 padding chars, and could potentially form corrupted data. +-- - @l = 5 mod 8@: 3 padding chars are added. If 3 padding chars are present in the string, this could form corrupted data like in the +-- previous case. +-- - @l = 6 mod 8@: Never an admissible length in base32 +-- - @l = 7 mod 8@: 1 padding char is added. If 5 padding chars are present in the string, this could form corrupted data like the +-- previous cases. +-- +-- Hence, permissive decodes should only fill in padding chars when it makes sense to add them. That is, +-- if an input is degenerate, it should never succeed when we add padding chars. We need the following invariant to hold: +-- +-- @ +-- B32.decodeUnpadded <|> B32.decodePadded ~ B32.decode +-- @ +-- +validateLastNPads + :: Int + -> ByteString + -> IO (Either Text ByteString) + -> Either Text ByteString +validateLastNPads !n (BS !fp !l) io + | not valid = Left "Base32-encoded bytestring has invalid padding" + | otherwise = unsafeDupablePerformIO io + where + valid = accursedUnutterablePerformIO $ withForeignPtr fp $ \p -> do + let end = plusPtr p l + + let go :: Ptr Word8 -> IO Bool + go !q + | q == end = return True + | otherwise = do + a <- peek q + if a == 0x3d then return False else go (plusPtr q 1) + + go (plusPtr p (l - n)) +{-# INLINE validateLastNPads #-} diff --git a/bundled/Data/ByteString/Base32/Internal/Head.hs b/bundled/Data/ByteString/Base32/Internal/Head.hs new file mode 100644 index 0000000..025429a --- /dev/null +++ b/bundled/Data/ByteString/Base32/Internal/Head.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeApplications #-} +module Data.ByteString.Base32.Internal.Head +( encodeBase32_ +, encodeBase32NoPad_ +, decodeBase32_ +) where + + +import Data.ByteString.Internal +import Data.ByteString.Base32.Internal.Loop +import Data.ByteString.Base32.Internal.Tail +import Data.Text (Text) + +import Foreign.Ptr +import Foreign.ForeignPtr + +import GHC.Exts +import GHC.ForeignPtr +import GHC.Word + +import System.IO.Unsafe + + +-- | Head of the padded base32 encoding loop. +-- +-- This function takes an alphabet in the form of an unboxed 'Addr#', +-- allocates the correct number of bytes that will be written, and +-- executes the inner encoding loop against that data. +-- +encodeBase32_ :: Addr# -> ByteString -> ByteString +encodeBase32_ !lut (BS !sfp !l) = unsafeDupablePerformIO $ do + dfp <- mallocPlainForeignPtrBytes dlen + withForeignPtr dfp $ \dptr -> + withForeignPtr sfp $ \sptr -> do + let !end = plusPtr sptr l + innerLoop lut + (castPtr dptr) sptr + end (loopTail lut dfp dptr end) + where + !dlen = ceiling (fromIntegral @_ @Double l / 5) * 8 + +-- | Head of the unpadded base32 encoding loop. +-- +-- This function takes an alphabet in the form of an unboxed 'Addr#', +-- allocates the correct number of bytes that will be written, and +-- executes the inner encoding loop against that data. +-- +encodeBase32NoPad_ :: Addr# -> ByteString -> ByteString +encodeBase32NoPad_ !lut (BS !sfp !l) = unsafeDupablePerformIO $ do + !dfp <- mallocPlainForeignPtrBytes dlen + withForeignPtr dfp $ \dptr -> + withForeignPtr sfp $ \sptr -> do + let !end = plusPtr sptr l + innerLoop lut + (castPtr dptr) sptr + end (loopTailNoPad lut dfp dptr end) + where + !dlen = ceiling (fromIntegral @_ @Double l / 5) * 8 + +-- | Head of the base32 decoding loop. +-- +-- This function takes a base32-decoding lookup table and base32-encoded +-- bytestring, allocates the correct number of bytes that will be written, +-- and executes the inner decoding loop against that data. +-- +decodeBase32_ :: Ptr Word8 -> ByteString -> IO (Either Text ByteString) +decodeBase32_ (Ptr !dtable) (BS !sfp !slen) = + withForeignPtr sfp $ \sptr -> do + dfp <- mallocPlainForeignPtrBytes dlen + withForeignPtr dfp $ \dptr -> do + let !end = plusPtr sptr slen + decodeLoop dtable dfp dptr sptr end + where + !dlen = ceiling (fromIntegral @_ @Double slen / 1.6) diff --git a/bundled/Data/ByteString/Base32/Internal/Loop.hs b/bundled/Data/ByteString/Base32/Internal/Loop.hs new file mode 100644 index 0000000..21e1446 --- /dev/null +++ b/bundled/Data/ByteString/Base32/Internal/Loop.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeApplications #-} +module Data.ByteString.Base32.Internal.Loop +( innerLoop +, decodeLoop +) where + +import Data.Bits +import Data.ByteString.Internal (ByteString(..)) +import Data.ByteString.Base32.Internal.Utils +import Data.Text (Text) +import qualified Data.Text as T + +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.Storable + +import GHC.Exts +import GHC.Word + + +-- ------------------------------------------------------------------------ -- +-- Encoding loops + +innerLoop + :: Addr# + -> Ptr Word64 + -> Ptr Word8 + -> Ptr Word8 + -> (Ptr Word8 -> Ptr Word8 -> IO ByteString) + -> IO ByteString +innerLoop !lut !dptr !sptr !end finish = go dptr sptr + where + lix a = w64 (aix (fromIntegral a .&. 0x1f) lut) + {-# INLINE lix #-} + + go !dst !src + | plusPtr src 4 >= end = finish (castPtr dst) src + | otherwise = do + !t <- peekWord32BE (castPtr src) + !u <- w32 <$> peek (plusPtr src 4) + + let !a = lix (unsafeShiftR t 27) + !b = lix (unsafeShiftR t 22) + !c = lix (unsafeShiftR t 17) + !d = lix (unsafeShiftR t 12) + !e = lix (unsafeShiftR t 7) + !f = lix (unsafeShiftR t 2) + !g = lix (unsafeShiftL t 3 .|. unsafeShiftR u 5) + !h = lix u + + let !w = a + .|. unsafeShiftL b 8 + .|. unsafeShiftL c 16 + .|. unsafeShiftL d 24 + .|. unsafeShiftL e 32 + .|. unsafeShiftL f 40 + .|. unsafeShiftL g 48 + .|. unsafeShiftL h 56 + + poke dst w + go (plusPtr dst 8) (plusPtr src 5) +{-# INLINE innerLoop #-} + +-- ------------------------------------------------------------------------ -- +-- Decoding loops + +decodeLoop + :: Addr# + -> ForeignPtr Word8 + -> Ptr Word8 + -> Ptr Word8 + -> Ptr Word8 + -> IO (Either Text ByteString) +decodeLoop !lut !dfp !dptr !sptr !end = go dptr sptr + where + lix a = w64 (aix (fromIntegral a) lut) + + err :: Ptr Word8 -> IO (Either Text ByteString) + err p = return . Left . T.pack + $ "invalid character at offset: " + ++ show (p `minusPtr` sptr) + + padErr :: Ptr Word8 -> IO (Either Text ByteString) + padErr p = return . Left . T.pack + $ "invalid padding at offset: " + ++ show (p `minusPtr` sptr) + + look :: Ptr Word8 -> IO Word64 + look !p = lix <$> peek @Word8 p + + go !dst !src + | plusPtr src 8 >= end = do + + a <- look src + b <- look (plusPtr src 1) + c <- look (plusPtr src 2) + d <- look (plusPtr src 3) + e <- look (plusPtr src 4) + f <- look (plusPtr src 5) + g <- look (plusPtr src 6) + h <- look (plusPtr src 7) + finalChunk dst src a b c d e f g h + + | otherwise = do + !t <- peekWord64BE (castPtr src) + + let a = lix (unsafeShiftR t 56) + b = lix (unsafeShiftR t 48) + c = lix (unsafeShiftR t 40) + d = lix (unsafeShiftR t 32) + e = lix (unsafeShiftR t 24) + f = lix (unsafeShiftR t 16) + g = lix (unsafeShiftR t 8) + h = lix t + + decodeChunk dst src a b c d e f g h + + finalChunk !dst !src !a !b !c !d !e !f !g !h + | a == 0x63 = padErr src + | b == 0x63 = padErr (plusPtr src 1) + | a == 0xff = err src + | b == 0xff = err (plusPtr src 1) + | c == 0xff = err (plusPtr src 2) + | d == 0xff = err (plusPtr src 3) + | e == 0xff = err (plusPtr src 4) + | f == 0xff = err (plusPtr src 5) + | g == 0xff = err (plusPtr src 6) + | h == 0xff = err (plusPtr src 7) + | otherwise = do + + let !o1 = (fromIntegral a `unsafeShiftL` 3) .|. (fromIntegral b `unsafeShiftR` 2) + !o2 = (fromIntegral b `unsafeShiftL` 6) + .|. (fromIntegral c `unsafeShiftL` 1) + .|. (fromIntegral d `unsafeShiftR` 4) + !o3 = (fromIntegral d `unsafeShiftL` 4) .|. (fromIntegral e `unsafeShiftR` 1) + !o4 = (fromIntegral e `unsafeShiftL` 7) + .|. (fromIntegral f `unsafeShiftL` 2) + .|. (fromIntegral g `unsafeShiftR` 3) + !o5 = (fromIntegral g `unsafeShiftL` 5) .|. fromIntegral h + + poke @Word8 dst o1 + poke @Word8 (plusPtr dst 1) o2 + + case (c,d,e,f,g,h) of + (0x63,0x63,0x63,0x63,0x63,0x63) -> + return (Right (BS dfp (1 + minusPtr dst dptr))) + (0x63,_,_,_,_,_) -> padErr (plusPtr src 3) + (_,0x63,0x63,0x63,0x63,0x63) -> padErr (plusPtr src 3) + (_,0x63,_,_,_,_) -> padErr (plusPtr src 4) + (_,_,0x63,0x63,0x63,0x63) -> do + poke @Word8 (plusPtr dst 2) o3 + return (Right (BS dfp (2 + minusPtr dst dptr))) + (_,_,0x63,_,_,_) -> padErr (plusPtr src 5) + (_,_,_,0x63,0x63,0x63) -> do + poke @Word8 (plusPtr dst 2) o3 + poke @Word8 (plusPtr dst 3) o4 + return (Right (BS dfp (3 + minusPtr dst dptr))) + (_,_,_,0x63,_,_) -> padErr (plusPtr src 6) + (_,_,_,_,0x63,0x63) -> padErr (plusPtr src 6) + (_,_,_,_,0x63,_) -> padErr (plusPtr src 7) + (_,_,_,_,_,0x63) -> do + poke @Word8 (plusPtr dst 2) o3 + poke @Word8 (plusPtr dst 3) o4 + poke @Word8 (plusPtr dst 4) o5 + return (Right (BS dfp (4 + minusPtr dst dptr))) + (_,_,_,_,_,_) -> do + poke @Word8 (plusPtr dst 2) o3 + poke @Word8 (plusPtr dst 3) o4 + poke @Word8 (plusPtr dst 4) o5 + return (Right (BS dfp (5 + minusPtr dst dptr))) + + decodeChunk !dst !src !a !b !c !d !e !f !g !h + | a == 0x63 = padErr src + | b == 0x63 = padErr (plusPtr src 1) + | c == 0x63 = padErr (plusPtr src 2) + | d == 0x63 = padErr (plusPtr src 3) + | e == 0x63 = padErr (plusPtr src 4) + | f == 0x63 = padErr (plusPtr src 5) + | g == 0x63 = padErr (plusPtr src 6) + | h == 0x63 = padErr (plusPtr src 7) + | a == 0xff = err src + | b == 0xff = err (plusPtr src 1) + | c == 0xff = err (plusPtr src 2) + | d == 0xff = err (plusPtr src 3) + | e == 0xff = err (plusPtr src 4) + | f == 0xff = err (plusPtr src 5) + | g == 0xff = err (plusPtr src 6) + | h == 0xff = err (plusPtr src 7) + | otherwise = do + + let !w = (unsafeShiftL a 35 + .|. unsafeShiftL b 30 + .|. unsafeShiftL c 25 + .|. unsafeShiftL d 20 + .|. unsafeShiftL e 15 + .|. unsafeShiftL f 10 + .|. unsafeShiftL g 5 + .|. h) :: Word64 + + poke @Word32 (castPtr dst) (byteSwap32 (fromIntegral (unsafeShiftR w 8))) + poke @Word8 (plusPtr dst 4) (fromIntegral w) + go (plusPtr dst 5) (plusPtr src 8) diff --git a/bundled/Data/ByteString/Base32/Internal/Tables.hs b/bundled/Data/ByteString/Base32/Internal/Tables.hs new file mode 100644 index 0000000..296a74a --- /dev/null +++ b/bundled/Data/ByteString/Base32/Internal/Tables.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TypeApplications #-} +module Data.ByteString.Base32.Internal.Tables +( stdDecodeTable +, hexDecodeTable +) where + + +import Data.ByteString.Base32.Internal.Utils (writeNPlainPtrBytes) + +import GHC.Word (Word8) +import GHC.Ptr (Ptr) + + +stdDecodeTable :: Ptr Word8 +stdDecodeTable = writeNPlainPtrBytes @Word8 256 + [ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0x1a,0x1b,0x1c,0x1d,0x1e,0x1f,0xff,0xff,0xff,0xff,0xff,0x63,0xff,0xff + , 0xff,0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a,0x0b,0x0c,0x0d,0x0e + , 0x0f,0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0xff,0xff,0xff,0xff,0xff + , 0xff,0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a,0x0b,0x0c,0x0d,0x0e + , 0x0f,0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + ] +{-# NOINLINE stdDecodeTable #-} + +hexDecodeTable :: Ptr Word8 +hexDecodeTable = writeNPlainPtrBytes @Word8 256 + [ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0xff,0xff,0xff,0x63,0xff,0xff + , 0xff,0x0a,0x0b,0x0c,0x0d,0x0e,0x0f,0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18 + , 0x19,0x1a,0x1b,0x1c,0x1d,0x1e,0x1f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0x0a,0x0b,0x0c,0x0d,0x0e,0x0f,0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18 + , 0x19,0x1a,0x1b,0x1c,0x1d,0x1e,0x1f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + ] +{-# NOINLINE hexDecodeTable #-} diff --git a/bundled/Data/ByteString/Base32/Internal/Tail.hs b/bundled/Data/ByteString/Base32/Internal/Tail.hs new file mode 100644 index 0000000..a6f7c8a --- /dev/null +++ b/bundled/Data/ByteString/Base32/Internal/Tail.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +module Data.ByteString.Base32.Internal.Tail +( loopTail +, loopTailNoPad +) where + + +import Data.Bits +import Data.ByteString.Internal +import Data.ByteString.Base32.Internal.Utils + +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.Storable + +import GHC.Exts +import GHC.Word + + +-- | Unroll final quantum encoding for base32 +-- +loopTail + :: Addr# + -> ForeignPtr Word8 + -> Ptr Word8 + -> Ptr Word8 + -> Ptr Word8 + -> Ptr Word8 + -> IO ByteString +loopTail !lut !dfp !dptr !end !dst !src + | src == end = return (BS dfp (minusPtr dst dptr)) + | plusPtr src 1 == end = do -- 2 6 + !a <- peek src + + let !t = look (unsafeShiftR (a .&. 0xf8) 3) + !u = look (unsafeShiftL (a .&. 0x07) 2) + + poke dst t + poke (plusPtr dst 1) u + padN (plusPtr dst 2) 6 + + return (BS dfp (8 + minusPtr dst dptr)) + | plusPtr src 2 == end = do -- 4 4 + !a <- peek src + !b <- peek (plusPtr src 1) + + let !t = look (unsafeShiftR (a .&. 0xf8) 3) + !u = look (unsafeShiftL (a .&. 0x07) 2 .|. unsafeShiftR (b .&. 0xc0) 6) + !v = look (unsafeShiftR (b .&. 0x3e) 1) + !w = look (unsafeShiftL (b .&. 0x01) 4) + + poke dst t + poke (plusPtr dst 1) u + poke (plusPtr dst 2) v + poke (plusPtr dst 3) w + padN (plusPtr dst 4) 4 + + return (BS dfp (8 + minusPtr dst dptr)) + | plusPtr src 3 == end = do -- 5 3 + !a <- peek src + !b <- peek (plusPtr src 1) + !c <- peek (plusPtr src 2) + + let !t = look (unsafeShiftR (a .&. 0xf8) 3) + !u = look (unsafeShiftL (a .&. 0x07) 2 .|. unsafeShiftR (b .&. 0xc0) 6) + !v = look (unsafeShiftR (b .&. 0x3e) 1) + !w = look (unsafeShiftL (b .&. 0x01) 4 .|. unsafeShiftR (c .&. 0xf0) 4) + !x = look (unsafeShiftL (c .&. 0x0f) 1) + + poke dst t + poke (plusPtr dst 1) u + poke (plusPtr dst 2) v + poke (plusPtr dst 3) w + poke (plusPtr dst 4) x + padN (plusPtr dst 5) 3 + return (BS dfp (8 + minusPtr dst dptr)) + + | otherwise = do -- 7 1 + !a <- peek src + !b <- peek (plusPtr src 1) + !c <- peek (plusPtr src 2) + !d <- peek (plusPtr src 3) + + let !t = look (unsafeShiftR (a .&. 0xf8) 3) + !u = look (unsafeShiftL (a .&. 0x07) 2 .|. unsafeShiftR (b .&. 0xc0) 6) + !v = look (unsafeShiftR (b .&. 0x3e) 1) + !w = look (unsafeShiftL (b .&. 0x01) 4 .|. unsafeShiftR (c .&. 0xf0) 4) + !x = look (unsafeShiftL (c .&. 0x0f) 1 .|. unsafeShiftR (d .&. 0x80) 7) + !y = look (unsafeShiftR (d .&. 0x7c) 2) + !z = look (unsafeShiftL (d .&. 0x03) 3) + + poke dst t + poke (plusPtr dst 1) u + poke (plusPtr dst 2) v + poke (plusPtr dst 3) w + poke (plusPtr dst 4) x + poke (plusPtr dst 5) y + poke (plusPtr dst 6) z + padN (plusPtr dst 7) 1 + return (BS dfp (8 + minusPtr dst dptr)) + where + look !n = aix n lut + + padN :: Ptr Word8 -> Int -> IO () + padN !_ 0 = return () + padN !p n = poke p 0x3d >> padN (plusPtr p 1) (n - 1) +{-# INLINE loopTail #-} + +-- | Unroll final quantum encoding for base32 +-- +loopTailNoPad + :: Addr# + -> ForeignPtr Word8 + -> Ptr Word8 + -> Ptr Word8 + -> Ptr Word8 + -> Ptr Word8 + -> IO ByteString +loopTailNoPad !lut !dfp !dptr !end !dst !src + | src == end = return (BS dfp (minusPtr dst dptr)) + | plusPtr src 1 == end = do -- 2 6 + !a <- peek src + + let !t = look (unsafeShiftR (a .&. 0xf8) 3) + !u = look (unsafeShiftL (a .&. 0x07) 2) + + poke dst t + poke (plusPtr dst 1) u + + return (BS dfp (2 + minusPtr dst dptr)) + + | plusPtr src 2 == end = do -- 4 4 + !a <- peek src + !b <- peek (plusPtr src 1) + + let !t = look (unsafeShiftR (a .&. 0xf8) 3) + !u = look (unsafeShiftL (a .&. 0x07) 2 .|. unsafeShiftR (b .&. 0xc0) 6) + !v = look (unsafeShiftR (b .&. 0x3e) 1) + !w = look (unsafeShiftL (b .&. 0x01) 4) + + poke dst t + poke (plusPtr dst 1) u + poke (plusPtr dst 2) v + poke (plusPtr dst 3) w + + return (BS dfp (4 + minusPtr dst dptr)) + + | plusPtr src 3 == end = do -- 5 3 + !a <- peek src + !b <- peek (plusPtr src 1) + !c <- peek (plusPtr src 2) + + let !t = look (unsafeShiftR (a .&. 0xf8) 3) + !u = look (unsafeShiftL (a .&. 0x07) 2 .|. unsafeShiftR (b .&. 0xc0) 6) + !v = look (unsafeShiftR (b .&. 0x3e) 1) + !w = look (unsafeShiftL (b .&. 0x01) 4 .|. unsafeShiftR (c .&. 0xf0) 4) + !x = look (unsafeShiftL (c .&. 0x0f) 1) + + poke dst t + poke (plusPtr dst 1) u + poke (plusPtr dst 2) v + poke (plusPtr dst 3) w + poke (plusPtr dst 4) x + return (BS dfp (5 + minusPtr dst dptr)) + + | otherwise = do -- 7 1 + !a <- peek src + !b <- peek (plusPtr src 1) + !c <- peek (plusPtr src 2) + !d <- peek (plusPtr src 3) + + let !t = look (unsafeShiftR (a .&. 0xf8) 3) + !u = look (unsafeShiftL (a .&. 0x07) 2 .|. unsafeShiftR (b .&. 0xc0) 6) + !v = look (unsafeShiftR (b .&. 0x3e) 1) + !w = look (unsafeShiftL (b .&. 0x01) 4 .|. unsafeShiftR (c .&. 0xf0) 4) + !x = look (unsafeShiftL (c .&. 0x0f) 1 .|. unsafeShiftR (d .&. 0x80) 7) + !y = look (unsafeShiftR (d .&. 0x7c) 2) + !z = look (unsafeShiftL (d .&. 0x03) 3) + + poke dst t + poke (plusPtr dst 1) u + poke (plusPtr dst 2) v + poke (plusPtr dst 3) w + poke (plusPtr dst 4) x + poke (plusPtr dst 5) y + poke (plusPtr dst 6) z + return (BS dfp (7 + minusPtr dst dptr)) + where + look !i = aix i lut +{-# INLINE loopTailNoPad #-} diff --git a/bundled/Data/ByteString/Base32/Internal/Utils.hs b/bundled/Data/ByteString/Base32/Internal/Utils.hs new file mode 100644 index 0000000..7ad4b04 --- /dev/null +++ b/bundled/Data/ByteString/Base32/Internal/Utils.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +module Data.ByteString.Base32.Internal.Utils +( aix +, peekWord32BE +, peekWord64BE +, reChunkN +, w32 +, w64 +, w64_32 +, writeNPlainPtrBytes +) where + + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS + +import Foreign.Ptr +import Foreign.Storable + +import GHC.ByteOrder +import GHC.Exts +import GHC.Word + +import System.IO.Unsafe +import Foreign.Marshal.Alloc (mallocBytes) + + +-- | Read 'Word8' index off alphabet addr +-- +aix :: Word8 -> Addr# -> Word8 +aix w8 alpha = W8# (indexWord8OffAddr# alpha i) + where + !(I# i) = fromIntegral w8 +{-# INLINE aix #-} + +w32 :: Word8 -> Word32 +w32 = fromIntegral +{-# INLINE w32 #-} + +w64_32 :: Word32 -> Word64 +w64_32 = fromIntegral +{-# INLINE w64_32 #-} + +w64 :: Word8 -> Word64 +w64 = fromIntegral +{-# INLINE w64 #-} + +-- | Allocate and fill @n@ bytes with some data +-- +writeNPlainPtrBytes + :: Storable a + => Int + -> [a] + -> Ptr a +writeNPlainPtrBytes !n as = unsafeDupablePerformIO $ do + p <- mallocBytes n + go p as + return p + where + go !_ [] = return () + go !p (x:xs) = poke p x >> go (plusPtr p 1) xs +{-# INLINE writeNPlainPtrBytes #-} + +peekWord32BE :: Ptr Word32 -> IO Word32 +peekWord32BE p = case targetByteOrder of + LittleEndian -> byteSwap32 <$> peek p + BigEndian -> peek p +{-# inline peekWord32BE #-} + +peekWord64BE :: Ptr Word64 -> IO Word64 +peekWord64BE p = case targetByteOrder of + LittleEndian -> byteSwap64 <$> peek p + BigEndian -> peek p +{-# inline peekWord64BE #-} + +-- | Rechunk a list of bytestrings in multiples of @n@ +-- +reChunkN :: Int -> [ByteString] -> [ByteString] +reChunkN n = go + where + go [] = [] + go (b:bs) = case divMod (BS.length b) n of + (_, 0) -> b : go bs + (d, _) -> case BS.splitAt (d * n) b of + ~(h, t) -> h : accum t bs + + accum acc [] = [acc] + accum acc (c:cs) = + case BS.splitAt (n - BS.length acc) c of + ~(h, t) -> + let acc' = BS.append acc h + in if BS.length acc' == n + then + let cs' = if BS.null t then cs else t : cs + in acc' : go cs' + else accum acc' cs +{-# INLINE reChunkN #-} diff --git a/bundled/Data/ByteString/Base64.hs b/bundled/Data/ByteString/Base64.hs new file mode 100644 index 0000000..1539303 --- /dev/null +++ b/bundled/Data/ByteString/Base64.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif + +-- | +-- Module : Data.ByteString.Base64 +-- Copyright : (c) 2010 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : Emily Pillmore , +-- Herbert Valerio Riedel , +-- Mikhail Glushenkov +-- Stability : experimental +-- Portability : GHC +-- +-- Fast and efficient encoding and decoding of base64-encoded strings. +-- +-- @since 0.1.0.0 +module Data.ByteString.Base64 + ( encode + , decode + , decodeLenient + ) where + +import Data.ByteString.Base64.Internal +import qualified Data.ByteString as B +import Data.ByteString.Internal (ByteString(..)) +import Data.Word (Word8) +import Foreign.ForeignPtr (ForeignPtr) + +-- | Encode a string into base64 form. The result will always be a +-- multiple of 4 bytes in length. +encode :: ByteString -> ByteString +encode s = encodeWith Padded (mkEncodeTable alphabet) s + +-- | Decode a base64-encoded string. This function strictly follows +-- the specification in +-- . +-- +-- (Note: this means that even @"\\n"@ and @"\\r\\n"@ as line breaks are rejected +-- rather than ignored. If you are using this in the context of a +-- standard that overrules RFC 4648 such as HTTP multipart mime bodies, +-- consider using 'decodeLenient'.) +decode :: ByteString -> Either String ByteString +decode s = decodeWithTable Padded decodeFP s + +-- | Decode a base64-encoded string. This function is lenient in +-- following the specification from +-- , and will not +-- generate parse errors no matter how poor its input. +decodeLenient :: ByteString -> ByteString +decodeLenient s = decodeLenientWithTable decodeFP s + +alphabet :: ByteString +alphabet = B.pack $ [65..90] ++ [97..122] ++ [48..57] ++ [43,47] +{-# NOINLINE alphabet #-} + +decodeFP :: ForeignPtr Word8 +#if MIN_VERSION_bytestring(0,11,0) +BS decodeFP _ = +#else +PS decodeFP _ _ = +#endif + B.pack $ replicate 43 x + ++ [62,x,x,x,63] + ++ [52..61] + ++ [x,x,x,done,x,x,x] + ++ [0..25] + ++ [x,x,x,x,x,x] + ++ [26..51] + ++ replicate 133 x +{-# NOINLINE decodeFP #-} + +x :: Integral a => a +x = 255 +{-# INLINE x #-} diff --git a/bundled/Data/ByteString/Base64/Internal.hs b/bundled/Data/ByteString/Base64/Internal.hs new file mode 100644 index 0000000..39eac49 --- /dev/null +++ b/bundled/Data/ByteString/Base64/Internal.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} +-- | +-- Module : Data.ByteString.Base64.Internal +-- Copyright : (c) 2010 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- Fast and efficient encoding and decoding of base64-encoded strings. + +module Data.ByteString.Base64.Internal + ( encodeWith + , decodeWithTable + , decodeLenientWithTable + , mkEncodeTable + , done + , peek8, poke8, peek8_32 + , reChunkIn + , Padding(..) + , withBS + , mkBS + ) where + +import Data.Bits ((.|.), (.&.), shiftL, shiftR) +import qualified Data.ByteString as B +import Data.ByteString.Internal (ByteString(..), mallocByteString) +import Data.Word (Word8, Word16, Word32) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, castForeignPtr) +import Foreign.Ptr (Ptr, castPtr, minusPtr, plusPtr) +import Foreign.Storable (peek, peekElemOff, poke) +import System.IO.Unsafe (unsafePerformIO) + +peek8 :: Ptr Word8 -> IO Word8 +peek8 = peek + +poke8 :: Ptr Word8 -> Word8 -> IO () +poke8 = poke + +peek8_32 :: Ptr Word8 -> IO Word32 +peek8_32 = fmap fromIntegral . peek8 + + +data Padding = Padded | Don'tCare | Unpadded deriving Eq + +-- | Encode a string into base64 form. The result will always be a multiple +-- of 4 bytes in length. +encodeWith :: Padding -> EncodeTable -> ByteString -> ByteString +encodeWith !padding (ET alfaFP encodeTable) !bs = withBS bs go + where + go !sptr !slen + | slen > maxBound `div` 4 = + error "Data.ByteString.Base64.encode: input too long" + | otherwise = do + let dlen = (slen + 2) `div` 3 * 4 + dfp <- mallocByteString dlen + withForeignPtr alfaFP $ \aptr -> + withForeignPtr encodeTable $ \ep -> do + let aidx n = peek8 (aptr `plusPtr` n) + sEnd = sptr `plusPtr` slen + finish !n = return $ mkBS dfp n + fill !dp !sp !n + | sp `plusPtr` 2 >= sEnd = complete (castPtr dp) sp n + | otherwise = {-# SCC "encode/fill" #-} do + i <- peek8_32 sp + j <- peek8_32 (sp `plusPtr` 1) + k <- peek8_32 (sp `plusPtr` 2) + let w = i `shiftL` 16 .|. j `shiftL` 8 .|. k + enc = peekElemOff ep . fromIntegral + poke dp =<< enc (w `shiftR` 12) + poke (dp `plusPtr` 2) =<< enc (w .&. 0xfff) + fill (dp `plusPtr` 4) (sp `plusPtr` 3) (n + 4) + complete dp sp n + | sp == sEnd = finish n + | otherwise = {-# SCC "encode/complete" #-} do + let peekSP m f = (f . fromIntegral) `fmap` peek8 (sp `plusPtr` m) + twoMore = sp `plusPtr` 2 == sEnd + equals = 0x3d :: Word8 + doPad = padding == Padded + {-# INLINE equals #-} + !a <- peekSP 0 ((`shiftR` 2) . (.&. 0xfc)) + !b <- peekSP 0 ((`shiftL` 4) . (.&. 0x03)) + + poke8 dp =<< aidx a + + if twoMore + then do + !b' <- peekSP 1 ((.|. b) . (`shiftR` 4) . (.&. 0xf0)) + !c <- aidx =<< peekSP 1 ((`shiftL` 2) . (.&. 0x0f)) + poke8 (dp `plusPtr` 1) =<< aidx b' + poke8 (dp `plusPtr` 2) c + + if doPad + then poke8 (dp `plusPtr` 3) equals >> finish (n + 4) + else finish (n + 3) + else do + poke8 (dp `plusPtr` 1) =<< aidx b + + if doPad + then do + poke8 (dp `plusPtr` 2) equals + poke8 (dp `plusPtr` 3) equals + finish (n + 4) + else finish (n + 2) + + + withForeignPtr dfp (\dptr -> fill (castPtr dptr) sptr 0) + +data EncodeTable = ET !(ForeignPtr Word8) !(ForeignPtr Word16) + +-- The encoding table is constructed such that the expansion of a 12-bit +-- block to a 16-bit block can be done by a single Word16 copy from the +-- correspoding table entry to the target address. The 16-bit blocks are +-- stored in big-endian order, as the indices into the table are built in +-- big-endian order. +mkEncodeTable :: ByteString -> EncodeTable +#if MIN_VERSION_bytestring(0,11,0) +mkEncodeTable alphabet@(BS afp _) = + case table of BS fp _ -> ET afp (castForeignPtr fp) +#else +mkEncodeTable alphabet@(PS afp _ _) = + case table of PS fp _ _ -> ET afp (castForeignPtr fp) +#endif + where + ix = fromIntegral . B.index alphabet + table = B.pack $ concat $ [ [ix j, ix k] | j <- [0..63], k <- [0..63] ] + +-- | Decode a base64-encoded string. This function strictly follows +-- the specification in . +-- +-- This function takes the decoding table (for @base64@ or @base64url@) as +-- the first parameter. +-- +-- For validation of padding properties, see note: $Validation +-- +decodeWithTable :: Padding -> ForeignPtr Word8 -> ByteString -> Either String ByteString +decodeWithTable padding !decodeFP bs + | B.length bs == 0 = Right B.empty + | otherwise = case padding of + Padded + | r == 0 -> withBS bs go + | r == 1 -> Left "Base64-encoded bytestring has invalid size" + | otherwise -> Left "Base64-encoded bytestring is unpadded or has invalid padding" + Don'tCare + | r == 0 -> withBS bs go + | r == 2 -> withBS (B.append bs (B.replicate 2 0x3d)) go + | r == 3 -> validateLastPad bs invalidPad $ withBS (B.append bs (B.replicate 1 0x3d)) go + | otherwise -> Left "Base64-encoded bytestring has invalid size" + Unpadded + | r == 0 -> validateLastPad bs noPad $ withBS bs go + | r == 2 -> validateLastPad bs noPad $ withBS (B.append bs (B.replicate 2 0x3d)) go + | r == 3 -> validateLastPad bs noPad $ withBS (B.append bs (B.replicate 1 0x3d)) go + | otherwise -> Left "Base64-encoded bytestring has invalid size" + where + !r = B.length bs `rem` 4 + + noPad = "Base64-encoded bytestring required to be unpadded" + invalidPad = "Base64-encoded bytestring has invalid padding" + + go !sptr !slen = do + dfp <- mallocByteString (slen `quot` 4 * 3) + withForeignPtr decodeFP (\ !decptr -> + withForeignPtr dfp (\dptr -> + decodeLoop decptr sptr dptr (sptr `plusPtr` slen) dfp)) + +decodeLoop + :: Ptr Word8 + -- ^ decoding table pointer + -> Ptr Word8 + -- ^ source pointer + -> Ptr Word8 + -- ^ destination pointer + -> Ptr Word8 + -- ^ source end pointer + -> ForeignPtr Word8 + -- ^ destination foreign pointer (used for finalizing string) + -> IO (Either String ByteString) +decodeLoop !dtable !sptr !dptr !end !dfp = go dptr sptr + where + err p = return . Left + $ "invalid character at offset: " + ++ show (p `minusPtr` sptr) + + padErr p = return . Left + $ "invalid padding at offset: " + ++ show (p `minusPtr` sptr) + + canonErr p = return . Left + $ "non-canonical encoding detected at offset: " + ++ show (p `minusPtr` sptr) + + look :: Ptr Word8 -> IO Word32 + look !p = do + !i <- peek p + !v <- peekElemOff dtable (fromIntegral i) + return (fromIntegral v) + + go !dst !src + | plusPtr src 4 >= end = do + !a <- look src + !b <- look (src `plusPtr` 1) + !c <- look (src `plusPtr` 2) + !d <- look (src `plusPtr` 3) + finalChunk dst src a b c d + + | otherwise = do + !a <- look src + !b <- look (src `plusPtr` 1) + !c <- look (src `plusPtr` 2) + !d <- look (src `plusPtr` 3) + decodeChunk dst src a b c d + + -- | Decodes chunks of 4 bytes at a time, recombining into + -- 3 bytes. Note that in the inner loop stage, no padding + -- characters are admissible. + -- + decodeChunk !dst !src !a !b !c !d + | a == 0x63 = padErr src + | b == 0x63 = padErr (plusPtr src 1) + | c == 0x63 = padErr (plusPtr src 2) + | d == 0x63 = padErr (plusPtr src 3) + | a == 0xff = err src + | b == 0xff = err (plusPtr src 1) + | c == 0xff = err (plusPtr src 2) + | d == 0xff = err (plusPtr src 3) + | otherwise = do + let !w = (shiftL a 18 + .|. shiftL b 12 + .|. shiftL c 6 + .|. d) :: Word32 + + poke8 dst (fromIntegral (shiftR w 16)) + poke8 (plusPtr dst 1) (fromIntegral (shiftR w 8)) + poke8 (plusPtr dst 2) (fromIntegral w) + go (plusPtr dst 3) (plusPtr src 4) + + -- | Decode the final 4 bytes in the string, recombining into + -- 3 bytes. Note that in this stage, we can have padding chars + -- but only in the final 2 positions. + -- + finalChunk !dst !src a b c d + | a == 0x63 = padErr src + | b == 0x63 = padErr (plusPtr src 1) + | c == 0x63 && d /= 0x63 = err (plusPtr src 3) -- make sure padding is coherent. + | a == 0xff = err src + | b == 0xff = err (plusPtr src 1) + | c == 0xff = err (plusPtr src 2) + | d == 0xff = err (plusPtr src 3) + | otherwise = do + let !w = (shiftL a 18 + .|. shiftL b 12 + .|. shiftL c 6 + .|. d) :: Word32 + + poke8 dst (fromIntegral (shiftR w 16)) + + if c == 0x63 && d == 0x63 + then + if sanityCheckPos b mask_4bits + then return $ Right $ mkBS dfp (1 + (dst `minusPtr` dptr)) + else canonErr (plusPtr src 1) + else if d == 0x63 + then + if sanityCheckPos c mask_2bits + then do + poke8 (plusPtr dst 1) (fromIntegral (shiftR w 8)) + return $ Right $ mkBS dfp (2 + (dst `minusPtr` dptr)) + else canonErr (plusPtr src 2) + else do + poke8 (plusPtr dst 1) (fromIntegral (shiftR w 8)) + poke8 (plusPtr dst 2) (fromIntegral w) + return $ Right $ mkBS dfp (3 + (dst `minusPtr` dptr)) + + +-- | Decode a base64-encoded string. This function is lenient in +-- following the specification from +-- , and will not +-- generate parse errors no matter how poor its input. This function +-- takes the decoding table (for @base64@ or @base64url@) as the first +-- paramert. +decodeLenientWithTable :: ForeignPtr Word8 -> ByteString -> ByteString +decodeLenientWithTable !decodeFP !bs = withBS bs go + where + go !sptr !slen + | dlen <= 0 = return B.empty + | otherwise = do + dfp <- mallocByteString dlen + withForeignPtr decodeFP $ \ !decptr -> do + let finish dbytes + | dbytes > 0 = return $ mkBS dfp dbytes + | otherwise = return B.empty + sEnd = sptr `plusPtr` slen + fill !dp !sp !n + | sp >= sEnd = finish n + | otherwise = {-# SCC "decodeLenientWithTable/fill" #-} + let look :: Bool -> Ptr Word8 + -> (Ptr Word8 -> Word32 -> IO ByteString) + -> IO ByteString + {-# INLINE look #-} + look skipPad p0 f = go' p0 + where + go' p | p >= sEnd = f (sEnd `plusPtr` (-1)) done + | otherwise = {-# SCC "decodeLenient/look" #-} do + ix <- fromIntegral `fmap` peek8 p + v <- peek8 (decptr `plusPtr` ix) + if v == x || v == done && skipPad + then go' (p `plusPtr` 1) + else f (p `plusPtr` 1) (fromIntegral v) + in look True sp $ \ !aNext !aValue -> + look True aNext $ \ !bNext !bValue -> + if aValue == done || bValue == done + then finish n + else + look False bNext $ \ !cNext !cValue -> + look False cNext $ \ !dNext !dValue -> do + let w = aValue `shiftL` 18 .|. bValue `shiftL` 12 .|. + cValue `shiftL` 6 .|. dValue + poke8 dp $ fromIntegral (w `shiftR` 16) + if cValue == done + then finish (n + 1) + else do + poke8 (dp `plusPtr` 1) $ fromIntegral (w `shiftR` 8) + if dValue == done + then finish (n + 2) + else do + poke8 (dp `plusPtr` 2) $ fromIntegral w + fill (dp `plusPtr` 3) dNext (n+3) + withForeignPtr dfp $ \dptr -> fill dptr sptr 0 + where + !dlen = (slen + 3) `div` 4 * 3 + +x :: Integral a => a +x = 255 +{-# INLINE x #-} + +done :: Integral a => a +done = 99 +{-# INLINE done #-} + +-- This takes a list of ByteStrings, and returns a list in which each +-- (apart from possibly the last) has length that is a multiple of n +reChunkIn :: Int -> [ByteString] -> [ByteString] +reChunkIn !n = go + where + go [] = [] + go (y : ys) = case B.length y `divMod` n of + (_, 0) -> y : go ys + (d, _) -> case B.splitAt (d * n) y of + (prefix, suffix) -> prefix : fixup suffix ys + fixup acc [] = [acc] + fixup acc (z : zs) = case B.splitAt (n - B.length acc) z of + (prefix, suffix) -> + let acc' = acc `B.append` prefix + in if B.length acc' == n + then let zs' = if B.null suffix + then zs + else suffix : zs + in acc' : go zs' + else -- suffix must be null + fixup acc' zs + +-- $Validation +-- +-- This function checks that the last char of a bytestring is '=' +-- and, if true, fails with a message or completes some io action. +-- +-- This is necessary to check when decoding permissively (i.e. filling in padding chars). +-- Consider the following 4 cases of a string of length l: +-- +-- l = 0 mod 4: No pad chars are added, since the input is assumed to be good. +-- l = 1 mod 4: Never an admissible length in base64 +-- l = 2 mod 4: 2 padding chars are added. If padding chars are present in the last 4 chars of the string, +-- they will fail to decode as final quanta. +-- l = 3 mod 4: 1 padding char is added. In this case a string is of the form + . If adding the +-- pad char "completes" the string so that it is `l = 0 mod 4`, then this may possibly form corrupted data. +-- This case is degenerate and should be disallowed. +-- +-- Hence, permissive decodes should only fill in padding chars when it makes sense to add them. That is, +-- if an input is degenerate, it should never succeed when we add padding chars. We need the following invariant to hold: +-- +-- @ +-- B64U.decodeUnpadded <|> B64U.decodePadded ~ B64U.decodePadded +-- @ +-- +-- This means the only char we need to check is the last one, and only to disallow `l = 3 mod 4`. +-- +validateLastPad + :: ByteString + -- ^ input to validate + -> String + -- ^ error msg + -> Either String ByteString + -> Either String ByteString +validateLastPad !bs err !io + | B.last bs == 0x3d = Left err + | otherwise = io +{-# INLINE validateLastPad #-} + +-- | Sanity check an index against a bitmask to make sure +-- it's coherent. If pos & mask == 0, we're good. If not, we should fail. +-- +sanityCheckPos :: Word32 -> Word8 -> Bool +sanityCheckPos pos mask = fromIntegral pos .&. mask == 0 +{-# INLINE sanityCheckPos #-} + +-- | Mask 2 bits +-- +mask_2bits :: Word8 +mask_2bits = 3 -- (1 << 2) - 1 +{-# NOINLINE mask_2bits #-} + +-- | Mask 4 bits +-- +mask_4bits :: Word8 +mask_4bits = 15 -- (1 << 4) - 1 +{-# NOINLINE mask_4bits #-} + +-- | Back-compat shim for bytestring >=0.11. Constructs a +-- bytestring from a foreign ptr and a length. Offset is 0. +-- +mkBS :: ForeignPtr Word8 -> Int -> ByteString +#if MIN_VERSION_bytestring(0,11,0) +mkBS dfp n = BS dfp n +#else +mkBS dfp n = PS dfp 0 n +#endif +{-# INLINE mkBS #-} + +-- | Back-compat shim for bytestring >=0.11. Unwraps the foreign ptr of +-- a bytestring, executing an IO action as a function of the underlying +-- pointer and some starting length. +-- +-- Note: in `unsafePerformIO`. +-- +withBS :: ByteString -> (Ptr Word8 -> Int -> IO a) -> a +#if MIN_VERSION_bytestring(0,11,0) +withBS (BS !sfp !slen) f = unsafePerformIO $ + withForeignPtr sfp $ \p -> f p slen +#else +withBS (PS !sfp !soff !slen) f = unsafePerformIO $ + withForeignPtr sfp $ \p -> f (plusPtr p soff) slen +#endif +{-# INLINE withBS #-} diff --git a/bundled/Data/ByteString/Base64/Lazy.hs b/bundled/Data/ByteString/Base64/Lazy.hs new file mode 100644 index 0000000..c7d7ffc --- /dev/null +++ b/bundled/Data/ByteString/Base64/Lazy.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif + +-- | +-- Module : Data.ByteString.Base64.Lazy +-- Copyright : (c) 2012 Ian Lynagh +-- +-- License : BSD-style +-- Maintainer : Emily Pillmore , +-- Herbert Valerio Riedel , +-- Mikhail Glushenkov +-- Stability : experimental +-- Portability : GHC +-- +-- Fast and efficient encoding and decoding of base64-encoded +-- lazy bytestrings. +-- +-- @since 1.0.0.0 +module Data.ByteString.Base64.Lazy + ( + encode + , decode + , decodeLenient + ) where + +import Data.ByteString.Base64.Internal +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC +import Data.Char + +-- | Encode a string into base64 form. The result will always be a +-- multiple of 4 bytes in length. +encode :: L.ByteString -> L.ByteString +encode = L.fromChunks . map B64.encode . reChunkIn 3 . L.toChunks + +-- | Decode a base64-encoded string. This function strictly follows +-- the specification in +-- . +decode :: L.ByteString -> Either String L.ByteString +decode b = -- Returning an Either type means that the entire result will + -- need to be in memory at once anyway, so we may as well + -- keep it simple and just convert to and from a strict byte + -- string + -- TODO: Use L.{fromStrict,toStrict} once we can rely on + -- a new enough bytestring + case B64.decode $ S.concat $ L.toChunks b of + Left err -> Left err + Right b' -> Right $ L.fromChunks [b'] + +-- | Decode a base64-encoded string. This function is lenient in +-- following the specification from +-- , and will not generate +-- parse errors no matter how poor its input. +decodeLenient :: L.ByteString -> L.ByteString +decodeLenient = L.fromChunks . map B64.decodeLenient . reChunkIn 4 . L.toChunks + . LC.filter goodChar + where -- We filter out and '=' padding here, but B64.decodeLenient + -- handles that + goodChar c = isDigit c || isAsciiUpper c || isAsciiLower c + || c == '+' || c == '/' diff --git a/bundled/Data/ByteString/Base64/URL.hs b/bundled/Data/ByteString/Base64/URL.hs new file mode 100644 index 0000000..eb3831e --- /dev/null +++ b/bundled/Data/ByteString/Base64/URL.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif + +-- | +-- Module : Data.ByteString.Base64.URL +-- Copyright : (c) 2012 Deian Stefan +-- +-- License : BSD-style +-- Maintainer : Emily Pillmore , +-- Herbert Valerio Riedel , +-- Mikhail Glushenkov +-- Stability : experimental +-- Portability : GHC +-- +-- Fast and efficient encoding and decoding of base64url-encoded strings. +-- +-- @since 0.1.1.0 +module Data.ByteString.Base64.URL + ( encode + , encodeUnpadded + , decode + , decodePadded + , decodeUnpadded + , decodeLenient + ) where + +import Data.ByteString.Base64.Internal +import qualified Data.ByteString as B +import Data.ByteString.Internal (ByteString(..)) +import Data.Word (Word8) +import Foreign.ForeignPtr (ForeignPtr) + +-- | Encode a string into base64url form. The result will always be a +-- multiple of 4 bytes in length. +encode :: ByteString -> ByteString +encode = encodeWith Padded (mkEncodeTable alphabet) + +-- | Encode a string into unpadded base64url form. +-- +-- @since 1.1.0.0 +encodeUnpadded :: ByteString -> ByteString +encodeUnpadded = encodeWith Unpadded (mkEncodeTable alphabet) + +-- | Decode a base64url-encoded string applying padding if necessary. +-- This function follows the specification in +-- and in +decode :: ByteString -> Either String ByteString +decode = decodeWithTable Don'tCare decodeFP + +-- | Decode a padded base64url-encoded string, failing if input is improperly padded. +-- This function follows the specification in +-- and in +-- +-- @since 1.1.0.0 +decodePadded :: ByteString -> Either String ByteString +decodePadded = decodeWithTable Padded decodeFP + +-- | Decode a unpadded base64url-encoded string, failing if input is padded. +-- This function follows the specification in +-- and in +-- +-- @since 1.1.0.0 +decodeUnpadded :: ByteString -> Either String ByteString +decodeUnpadded = decodeWithTable Unpadded decodeFP + +-- | Decode a base64url-encoded string. This function is lenient in +-- following the specification from +-- , and will not +-- generate parse errors no matter how poor its input. +decodeLenient :: ByteString -> ByteString +decodeLenient = decodeLenientWithTable decodeFP + + +alphabet :: ByteString +alphabet = B.pack $ [65..90] ++ [97..122] ++ [48..57] ++ [45,95] +{-# NOINLINE alphabet #-} + +decodeFP :: ForeignPtr Word8 +#if MIN_VERSION_bytestring(0,11,0) +BS decodeFP _ = +#else +PS decodeFP _ _ = +#endif + B.pack $ replicate 45 x + ++ [62,x,x] + ++ [52..61] + ++ [x,x,x,done,x,x,x] + ++ [0..25] + ++ [x,x,x,x,63,x] + ++ [26..51] + ++ replicate 133 x + +{-# NOINLINE decodeFP #-} + +x :: Integral a => a +x = 255 +{-# INLINE x #-} diff --git a/bundled/Data/ByteString/Base64/URL/Lazy.hs b/bundled/Data/ByteString/Base64/URL/Lazy.hs new file mode 100644 index 0000000..672a89b --- /dev/null +++ b/bundled/Data/ByteString/Base64/URL/Lazy.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif + +-- | +-- Module : Data.ByteString.Base64.URL.Lazy +-- Copyright : (c) 2012 Ian Lynagh +-- +-- License : BSD-style +-- Maintainer : Emily Pillmore , +-- Herbert Valerio Riedel , +-- Mikhail Glushenkov +-- Stability : experimental +-- Portability : GHC +-- +-- Fast and efficient encoding and decoding of base64-encoded +-- lazy bytestrings. +-- +-- @since 1.0.0.0 +module Data.ByteString.Base64.URL.Lazy + ( + encode + , encodeUnpadded + , decode + , decodeUnpadded + , decodePadded + , decodeLenient + ) where + +import Data.ByteString.Base64.Internal +import qualified Data.ByteString.Base64.URL as B64 +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC +import Data.Char + +-- | Encode a string into base64 form. The result will always be a +-- multiple of 4 bytes in length. +encode :: L.ByteString -> L.ByteString +encode = L.fromChunks . map B64.encode . reChunkIn 3 . L.toChunks + +-- | Encode a string into unpadded base64url form. +-- +-- @since 1.1.0.0 +encodeUnpadded :: L.ByteString -> L.ByteString +encodeUnpadded = L.fromChunks + . map B64.encodeUnpadded + . reChunkIn 3 + . L.toChunks + +-- | Decode a base64-encoded string. This function strictly follows +-- the specification in +-- . +decode :: L.ByteString -> Either String L.ByteString +decode b = -- Returning an Either type means that the entire result will + -- need to be in memory at once anyway, so we may as well + -- keep it simple and just convert to and from a strict byte + -- string + -- TODO: Use L.{fromStrict,toStrict} once we can rely on + -- a new enough bytestring + case B64.decode $ S.concat $ L.toChunks b of + Left err -> Left err + Right b' -> Right $ L.fromChunks [b'] + +-- | Decode a unpadded base64url-encoded string, failing if input is padded. +-- This function follows the specification in +-- and in +-- +-- @since 1.1.0.0 +decodeUnpadded :: L.ByteString -> Either String L.ByteString +decodeUnpadded bs = case B64.decodeUnpadded $ S.concat $ L.toChunks bs of + Right b -> Right $ L.fromChunks [b] + Left e -> Left e + +-- | Decode a padded base64url-encoded string, failing if input is improperly padded. +-- This function follows the specification in +-- and in +-- +-- @since 1.1.0.0 +decodePadded :: L.ByteString -> Either String L.ByteString +decodePadded bs = case B64.decodePadded $ S.concat $ L.toChunks bs of + Right b -> Right $ L.fromChunks [b] + Left e -> Left e + +-- | Decode a base64-encoded string. This function is lenient in +-- following the specification from +-- , and will not generate +-- parse errors no matter how poor its input. +decodeLenient :: L.ByteString -> L.ByteString +decodeLenient = L.fromChunks . map B64.decodeLenient . reChunkIn 4 . L.toChunks + . LC.filter goodChar + where -- We filter out and '=' padding here, but B64.decodeLenient + -- handles that + goodChar c = isAlphaNum c || c == '-' || c == '_' diff --git a/bundled/Data/ByteString/Builder/Scientific.hs b/bundled/Data/ByteString/Builder/Scientific.hs new file mode 100644 index 0000000..4d25150 --- /dev/null +++ b/bundled/Data/ByteString/Builder/Scientific.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE OverloadedStrings, Safe #-} + +module Data.ByteString.Builder.Scientific + ( scientificBuilder + , formatScientificBuilder + , FPFormat(..) + ) where + +import Data.Scientific (Scientific) +import qualified Data.Scientific as Scientific + +import Data.Text.Lazy.Builder.RealFloat (FPFormat(..)) + +import qualified Data.ByteString.Char8 as BC8 +import Data.ByteString.Builder (Builder, string8, char8, intDec) +import Data.ByteString.Builder.Extra (byteStringCopy) + +import Utils (roundTo, i2d) + +import Data.Monoid ((<>)) + + +-- | A @ByteString@ @Builder@ which renders a scientific number to full +-- precision, using standard decimal notation for arguments whose +-- absolute value lies between @0.1@ and @9,999,999@, and scientific +-- notation otherwise. +scientificBuilder :: Scientific -> Builder +scientificBuilder = formatScientificBuilder Generic Nothing + +-- | Like 'scientificBuilder' but provides rendering options. +formatScientificBuilder :: FPFormat + -> Maybe Int -- ^ Number of decimal places to render. + -> Scientific + -> Builder +formatScientificBuilder fmt decs scntfc + | scntfc < 0 = char8 '-' <> doFmt fmt (Scientific.toDecimalDigits (-scntfc)) + | otherwise = doFmt fmt (Scientific.toDecimalDigits scntfc) + where + doFmt format (is, e) = + let ds = map i2d is in + case format of + Generic -> + doFmt (if e < 0 || e > 7 then Exponent else Fixed) + (is,e) + Exponent -> + case decs of + Nothing -> + let show_e' = intDec (e-1) in + case ds of + "0" -> byteStringCopy "0.0e0" + [d] -> char8 d <> byteStringCopy ".0e" <> show_e' + (d:ds') -> char8 d <> char8 '.' <> string8 ds' <> char8 'e' <> show_e' + [] -> error $ "Data.ByteString.Builder.Scientific.formatScientificBuilder" ++ + "/doFmt/Exponent: []" + Just dec -> + let dec' = max dec 1 in + case is of + [0] -> byteStringCopy "0." <> + byteStringCopy (BC8.replicate dec' '0') <> + byteStringCopy "e0" + _ -> + let (ei,is') = roundTo (dec'+1) is + in case map i2d (if ei > 0 then init is' else is') of + [] -> mempty + d:ds' -> char8 d <> char8 '.' <> string8 ds' <> char8 'e' <> intDec (e-1+ei) + Fixed -> + let + mk0 ls = case ls of { "" -> char8 '0' ; _ -> string8 ls} + in + case decs of + Nothing + | e <= 0 -> byteStringCopy "0." <> + byteStringCopy (BC8.replicate (-e) '0') <> + string8 ds + | otherwise -> + let + f 0 s rs = mk0 (reverse s) <> char8 '.' <> mk0 rs + f n s "" = f (n-1) ('0':s) "" + f n s (r:rs) = f (n-1) (r:s) rs + in + f e "" ds + Just dec -> + let dec' = max dec 0 in + if e >= 0 then + let + (ei,is') = roundTo (dec' + e) is + (ls,rs) = splitAt (e+ei) (map i2d is') + in + mk0 ls <> (if null rs then mempty else char8 '.' <> string8 rs) + else + let (ei,is') = roundTo dec' (replicate (-e) 0 ++ is) + in case map i2d (if ei > 0 then is' else 0:is') of + [] -> mempty + d:ds' -> char8 d <> (if null ds' then mempty else char8 '.' <> string8 ds') diff --git a/bundled/Data/ByteString/Lazy/Base32.hs b/bundled/Data/ByteString/Lazy/Base32.hs new file mode 100644 index 0000000..df18f96 --- /dev/null +++ b/bundled/Data/ByteString/Lazy/Base32.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} +-- | +-- Module : Data.ByteString.Lazy.Base32 +-- Copyright : (c) 2019-2023 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains 'Data.ByteString.Lazy.ByteString'-valued combinators for +-- implementing the RFC 4648 specification of the Base32 +-- encoding format. This includes strictly padded/unpadded +-- decoding variants, as well as internal and external validation for canonicity. +-- +module Data.ByteString.Lazy.Base32 +( -- * Encoding + encodeBase32 +, encodeBase32' +, encodeBase32Unpadded +, encodeBase32Unpadded' + -- * Decoding +, decodeBase32 +, decodeBase32Unpadded +, decodeBase32Padded +--, decodeBase32Lenient + -- * Validation +, isBase32 +, isValidBase32 +) where + + +import Prelude hiding (all, elem) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base32 as B32 +import Data.ByteString.Base32.Internal.Utils (reChunkN) +import Data.ByteString.Lazy (elem, fromChunks, toChunks) +import Data.ByteString.Lazy.Internal (ByteString(..)) +import Data.Either (isRight) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL + + +-- | Encode a 'ByteString' value as a Base32 'Text' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "KN2W4===" +-- +encodeBase32 :: ByteString -> TL.Text +encodeBase32 = TL.decodeUtf8 . encodeBase32' +{-# INLINE encodeBase32 #-} + +-- | Encode a 'ByteString' as a Base32 'ByteString' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "KN2W4===" +-- +encodeBase32' :: ByteString -> ByteString +encodeBase32' = fromChunks + . fmap B32.encodeBase32' + . reChunkN 5 + . toChunks + +-- | Decode an arbitrarily padded Base32 encoded 'ByteString' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as Base32-encoded values are optionally padded. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32 "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32 :: ByteString -> Either T.Text ByteString +decodeBase32 = fmap (fromChunks . (:[])) + . B32.decodeBase32 + . BS.concat + . toChunks +{-# INLINE decodeBase32 #-} + +-- | Encode a 'ByteString' value as Base32 'Text' without padding. Note that for Base32, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32 and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded "Sun" +-- "KN2W4" +-- +encodeBase32Unpadded :: ByteString -> TL.Text +encodeBase32Unpadded = TL.decodeUtf8 . encodeBase32Unpadded' +{-# INLINE encodeBase32Unpadded #-} + +-- | Encode a 'ByteString' value as Base32 without padding. Note that for Base32, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32 and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded' "Sun" +-- "KN2W4" +-- +encodeBase32Unpadded' :: ByteString -> ByteString +encodeBase32Unpadded' = fromChunks + . fmap B32.encodeBase32Unpadded' + . reChunkN 5 + . toChunks + +-- | Decode an unpadded Base32-encoded 'ByteString' value. Input strings are +-- required to be unpadded, and will undergo validation prior to decoding to +-- confirm. +-- +-- In general, unless unpadded Base32 is explicitly required, it is +-- safer to call 'decodeBase32'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "KN2W4===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32Unpadded :: ByteString -> Either T.Text ByteString +decodeBase32Unpadded = fmap (fromChunks . (:[])) + . B32.decodeBase32Unpadded + . BS.concat + . toChunks +{-# INLINE decodeBase32Unpadded #-} + +-- | Decode a padded Base32-encoded 'ByteString' value. Input strings are +-- required to be correctly padded, and will be validated prior to decoding +-- to confirm. +-- +-- In general, unless padded Base32 is explicitly required, it is +-- safer to call 'decodeBase32'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "KN2W4" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: ByteString -> Either T.Text ByteString +decodeBase32Padded = fmap (fromChunks . (:[])) + . B32.decodeBase32Padded + . BS.concat + . toChunks +{-# INLINE decodeBase32Padded #-} + +-- -- | Leniently decode an unpadded Base32-encoded 'ByteString'. This function +-- -- will not generate parse errors. If input data contains padding chars, +-- -- then the input will be parsed up until the first pad character. +-- -- +-- -- __Note:__ This is not RFC 4648-compliant. +-- -- +-- -- === __Examples__: +-- -- +-- -- >>> decodeBase32Lenient "PDw_Pj4=" +-- -- "<>" +-- -- +-- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" +-- -- "<>" +-- -- +-- decodeBase32Lenient :: ByteString -> ByteString +-- decodeBase32Lenient = fromChunks +-- . fmap B32.decodeBase32Lenient +-- . reChunkN 8 +-- . fmap (BS.filter (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567=")) +-- . toChunks +-- {-# INLINE decodeBase32Lenient #-} + +-- | Tell whether a 'ByteString' is Base32-encoded. +-- +-- === __Examples__: +-- +-- >>> isBase32 "KN2W4" +-- True +-- +-- >>> isBase32 "KN2W4===" +-- True +-- +-- >>> isBase32 "KN2W4==" +-- False +-- +isBase32 :: ByteString -> Bool +isBase32 bs = isValidBase32 bs && isRight (decodeBase32 bs) +{-# INLINE isBase32 #-} + +-- | Tell whether a 'ByteString' is a valid Base32 format. +-- +-- This will not tell you whether or not this is a correct Base32 representation, +-- only that it conforms to the correct shape. To check whether it is a true +-- Base32 encoded 'ByteString' value, use 'isBase32'. +-- +-- === __Examples__: +-- +-- >>> isValidBase32 "KN2W4" +-- True +-- +-- >>> isValidBase32 "KN2W4=" +-- False +-- +-- >>> isValidBase32 "KN2W4%" +-- False +-- +isValidBase32 :: ByteString -> Bool +isValidBase32 = go . toChunks + where + go [] = True + go [c] = B32.isValidBase32 c + go (c:cs) = -- note the lack of padding char + BS.all (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567") c + && go cs +{-# INLINE isValidBase32 #-} diff --git a/bundled/Data/ByteString/Lazy/Base32/Hex.hs b/bundled/Data/ByteString/Lazy/Base32/Hex.hs new file mode 100644 index 0000000..c2c639e --- /dev/null +++ b/bundled/Data/ByteString/Lazy/Base32/Hex.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} +-- | +-- Module : Data.ByteString.Lazy.Base32.Hex +-- Copyright : (c) 2019-2023 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains 'Data.ByteString.Lazy.ByteString'-valued combinators for +-- implementing the RFC 4648 specification of the Base32hex +-- encoding format. This includes strictly padded/unpadded +-- decoding variants, as well as internal and external validation for canonicity. +-- +module Data.ByteString.Lazy.Base32.Hex +( -- * Encoding + encodeBase32 +, encodeBase32' +, encodeBase32Unpadded +, encodeBase32Unpadded' + -- * Decoding +, decodeBase32 +, decodeBase32Unpadded +, decodeBase32Padded +--, decodeBase32Lenient + -- * Validation +, isBase32Hex +, isValidBase32Hex +) where + + +import Prelude hiding (all, elem) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base32.Hex as B32H +import Data.ByteString.Base32.Internal.Utils (reChunkN) +import Data.ByteString.Lazy (elem, fromChunks, toChunks) +import Data.ByteString.Lazy.Internal (ByteString(..)) +import Data.Either (isRight) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL + + +-- | Encode a 'ByteString' value as a Base32hex 'Text' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "ADQMS===" +-- +encodeBase32 :: ByteString -> TL.Text +encodeBase32 = TL.decodeUtf8 . encodeBase32' +{-# INLINE encodeBase32 #-} + +-- | Encode a 'ByteString' as a Base32hex 'ByteString' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32' "Sun" +-- "ADQMS===" +-- +encodeBase32' :: ByteString -> ByteString +encodeBase32' = fromChunks + . fmap B32H.encodeBase32' + . reChunkN 5 + . toChunks + +-- | Decode an arbitrarily padded Base32hex encoded 'ByteString' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as Base32hex-encoded values are optionally padded. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32 "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32 :: ByteString -> Either T.Text ByteString +decodeBase32 = fmap (fromChunks . (:[])) + . B32H.decodeBase32 + . BS.concat + . toChunks +{-# INLINE decodeBase32 #-} + +-- | Encode a 'ByteString' value as Base32hex 'Text' without padding. Note that for Base32hex, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32hex and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded "Sun" +-- "ADQMS" +-- +encodeBase32Unpadded :: ByteString -> TL.Text +encodeBase32Unpadded = TL.decodeUtf8 . encodeBase32Unpadded' +{-# INLINE encodeBase32Unpadded #-} + +-- | Encode a 'ByteString' value as Base32hex without padding. Note that for Base32hex, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32hex and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded' "Sun" +-- "ADQMS" +-- +encodeBase32Unpadded' :: ByteString -> ByteString +encodeBase32Unpadded' = fromChunks + . fmap B32H.encodeBase32Unpadded' + . reChunkN 5 + . toChunks + +-- | Decode an unpadded Base32hex-encoded 'ByteString' value. Input strings are +-- required to be unpadded, and will undergo validation prior to decoding to +-- confirm. +-- +-- In general, unless unpadded Base32hex is explicitly required, it is +-- safer to call 'decodeBase32'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32Unpadded :: ByteString -> Either T.Text ByteString +decodeBase32Unpadded = fmap (fromChunks . (:[])) + . B32H.decodeBase32Unpadded + . BS.concat + . toChunks +{-# INLINE decodeBase32Unpadded #-} + +-- | Decode a padded Base32hex-encoded 'ByteString' value. Input strings are +-- required to be correctly padded, and will be validated prior to decoding +-- to confirm. +-- +-- In general, unless padded Base32hex is explicitly required, it is +-- safer to call 'decodeBase32'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "ADQMS" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: ByteString -> Either T.Text ByteString +decodeBase32Padded = fmap (fromChunks . (:[])) + . B32H.decodeBase32Padded + . BS.concat + . toChunks +{-# INLINE decodeBase32Padded #-} + +-- -- | Leniently decode an unpadded Base32hex-encoded 'ByteString'. This function +-- -- will not generate parse errors. If input data contains padding chars, +-- -- then the input will be parsed up until the first pad character. +-- -- +-- -- __Note:__ This is not RFC 4648-compliant. +-- -- +-- -- === __Examples__: +-- -- +-- -- >>> decodeBase32Lenient "PDw_Pj4=" +-- -- "<>" +-- -- +-- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" +-- -- "<>" +-- -- +-- decodeBase32Lenient :: ByteString -> ByteString +-- decodeBase32Lenient = fromChunks +-- . fmap B32H.decodeBase32Lenient +-- . reChunkN 8 +-- . fmap (BS.filter (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567=")) +-- . toChunks +-- {-# INLINE decodeBase32Lenient #-} + +-- | Tell whether a 'ByteString' is Base32hex-encoded. +-- +-- === __Examples__: +-- +-- >>> isBase32Hex "ADQMS" +-- True +-- +-- >>> isBase32Hex "ADQMS===" +-- True +-- +-- >>> isBase32Hex "ADQMS==" +-- False +-- +isBase32Hex :: ByteString -> Bool +isBase32Hex bs = isValidBase32Hex bs && isRight (decodeBase32 bs) +{-# INLINE isBase32Hex #-} + +-- | Tell whether a 'ByteString' is a valid Base32hex format. +-- +-- This will not tell you whether or not this is a correct Base32hex representation, +-- only that it conforms to the correct shape. To check whether it is a true +-- Base32hex encoded 'ByteString' value, use 'isBase32Hex'. +-- +-- === __Examples__: +-- +-- +-- >>> isValidBase32Hex "ADQMS" +-- True +-- +-- >>> isValidBase32Hex "ADQMS=" +-- False +-- +-- >>> isValidBase32Hex "ADQMS%" +-- False +-- +isValidBase32Hex :: ByteString -> Bool +isValidBase32Hex = go . toChunks + where + go [] = True + go [c] = B32H.isValidBase32Hex c + go (c:cs) = -- note the lack of padding char + BS.all (flip elem "0123456789ABCDEFGHIJKLMNOPQRSTUV") c + && go cs +{-# INLINE isValidBase32Hex #-} diff --git a/bundled/Data/ByteString/Short/Base32.hs b/bundled/Data/ByteString/Short/Base32.hs new file mode 100644 index 0000000..ee396b2 --- /dev/null +++ b/bundled/Data/ByteString/Short/Base32.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE Trustworthy #-} +-- | +-- Module : Data.ByteString.Short.Base32 +-- Copyright : (c) 2019-2023 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains 'Data.ByteString.Short.ShortByteString'-valued combinators for +-- implementing the RFC 4648 specification of the Base32 +-- encoding format. This includes strictly padded/unpadded decoding +-- variants, as well as internal and external validation for canonicity. +-- +module Data.ByteString.Short.Base32 +( -- * Encoding + encodeBase32 +, encodeBase32' +, encodeBase32Unpadded +, encodeBase32Unpadded' + -- * Decoding +, decodeBase32 +, decodeBase32Unpadded +, decodeBase32Padded +--, decodeBase32Lenient + -- * Validation +, isBase32 +, isValidBase32 +) where + + +import qualified Data.ByteString.Base32 as B32 +import Data.ByteString.Short (ShortByteString, fromShort, toShort) +import Data.Text (Text) +import Data.Text.Short (ShortText) +import Data.Text.Short.Unsafe (fromShortByteStringUnsafe) + + +-- | Encode a 'ShortByteString' value as a Base32 'Text' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "KN2W4===" +-- +encodeBase32 :: ShortByteString -> ShortText +encodeBase32 = fromShortByteStringUnsafe . encodeBase32' +{-# INLINE encodeBase32 #-} + +-- | Encode a 'ShortByteString' as a Base32 'ShortByteString' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32' "Sun" +-- "KN2W4===" +-- +encodeBase32' :: ShortByteString -> ShortByteString +encodeBase32' = toShort . B32.encodeBase32' . fromShort + +-- | Decode an arbitrarily padded Base32 encoded 'ShortByteString' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as Base32-encoded values are optionally padded. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32 "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32 :: ShortByteString -> Either Text ShortByteString +decodeBase32 = fmap toShort . B32.decodeBase32 . fromShort + +{-# INLINE decodeBase32 #-} + +-- | Encode a 'ShortByteString' value as Base32 'Text' without padding. Note that for Base32, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32 and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded "Sun" +-- "KN2W4" +-- +encodeBase32Unpadded :: ShortByteString -> ShortText +encodeBase32Unpadded = fromShortByteStringUnsafe . encodeBase32Unpadded' +{-# INLINE encodeBase32Unpadded #-} + +-- | Encode a 'ShortByteString' value as Base32 without padding. Note that for Base32, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32 and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded' "Sun" +-- "KN2W4" +-- +encodeBase32Unpadded' :: ShortByteString -> ShortByteString +encodeBase32Unpadded' = toShort . B32.encodeBase32Unpadded' . fromShort + +-- | Decode an unpadded Base32-encoded 'ShortByteString' value. Input strings are +-- required to be unpadded, and will undergo validation prior to decoding to +-- confirm. +-- +-- In general, unless unpadded Base32 is explicitly required, it is +-- safer to call 'decodeBase32'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "KN2W4===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32Unpadded :: ShortByteString -> Either Text ShortByteString +decodeBase32Unpadded = fmap toShort . B32.decodeBase32Unpadded . fromShort +{-# INLINE decodeBase32Unpadded #-} + +-- | Decode a padded Base32-encoded 'ShortByteString' value. Input strings are +-- required to be correctly padded, and will be validated prior to decoding +-- to confirm. +-- +-- In general, unless padded Base32 is explicitly required, it is +-- safer to call 'decodeBase32'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "KN2W4" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: ShortByteString -> Either Text ShortByteString +decodeBase32Padded = fmap toShort . B32.decodeBase32Padded . fromShort +{-# INLINE decodeBase32Padded #-} + +-- -- | Leniently decode an unpadded Base32-encoded 'ShortByteString'. This function +-- -- will not generate parse errors. If input data contains padding chars, +-- -- then the input will be parsed up until the first pad character. +-- -- +-- -- __Note:__ This is not RFC 4648-compliant. +-- -- +-- -- === __Examples__: +-- -- +-- -- >>> decodeBase32Lenient "PDw_Pj4=" +-- -- "<>" +-- -- +-- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" +-- -- "<>" +-- -- +-- decodeBase32Lenient :: ShortByteString -> ShortByteString +-- decodeBase32Lenient = toShort . B32.decodeBase32Lenient . fromShort +-- {-# INLINE decodeBase32Lenient #-} + +-- | Tell whether a 'ShortByteString' is Base32-encoded. +-- +-- === __Examples__: +-- +-- >>> isBase32 "KN2W4" +-- True +-- +-- >>> isBase32 "KN2W4===" +-- True +-- +-- >>> isBase32 "KN2W4==" +-- False +-- +isBase32 :: ShortByteString -> Bool +isBase32 = B32.isBase32 . fromShort +{-# INLINE isBase32 #-} + +-- | Tell whether a 'ShortByteString' is a valid Base32 format. +-- +-- This will not tell you whether or not this is a correct Base32 representation, +-- only that it conforms to the correct shape. To check whether it is a true +-- Base32 encoded 'ShortByteString' value, use 'isBase32'. +-- +-- === __Examples__: +-- +-- >>> isValidBase32 "KN2W4" +-- True +-- +-- >>> isValidBase32 "KN2W4=" +-- False +-- +-- >>> isValidBase32 "KN2W4%" +-- False +-- +isValidBase32 :: ShortByteString -> Bool +isValidBase32 = B32.isValidBase32 . fromShort +{-# INLINE isValidBase32 #-} diff --git a/bundled/Data/ByteString/Short/Base32/Hex.hs b/bundled/Data/ByteString/Short/Base32/Hex.hs new file mode 100644 index 0000000..bfe7516 --- /dev/null +++ b/bundled/Data/ByteString/Short/Base32/Hex.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE Trustworthy #-} +-- | +-- Module : Data.ByteString.Short.Base32.Hex +-- Copyright : (c) 2019-2023 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains 'Data.ByteString.Short.ShortByteString'-valued combinators for +-- implementing the RFC 4648 specification of the Base32hex +-- encoding format. This includes strictly padded/unpadded and decoding +-- variants, as well as internal and external validation for canonicity. +-- +module Data.ByteString.Short.Base32.Hex +( -- * Encoding + encodeBase32 +, encodeBase32' +, encodeBase32Unpadded +, encodeBase32Unpadded' + -- * Decoding +, decodeBase32 +, decodeBase32Unpadded +, decodeBase32Padded +--, decodeBase32Lenient + -- * Validation +, isBase32Hex +, isValidBase32Hex +) where + + +import qualified Data.ByteString.Base32.Hex as B32H +import Data.ByteString.Short (ShortByteString, fromShort, toShort) +import Data.Text (Text) +import Data.Text.Short (ShortText) +import Data.Text.Short.Unsafe (fromShortByteStringUnsafe) + +-- | Encode a 'ShortByteString' value as a Base32hex 'Text' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "ADQMS===" +-- +encodeBase32 :: ShortByteString -> ShortText +encodeBase32 = fromShortByteStringUnsafe . encodeBase32' +{-# INLINE encodeBase32 #-} + +-- | Encode a 'ShortByteString' as a Base32hex 'ShortByteString' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32' "Sun" +-- "ADQMS===" +-- +encodeBase32' :: ShortByteString -> ShortByteString +encodeBase32' = toShort . B32H.encodeBase32' . fromShort + +-- | Decode an arbitrarily padded Base32hex encoded 'ShortByteString' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as Base32hex-encoded values are optionally padded. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32 "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQM===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32 :: ShortByteString -> Either Text ShortByteString +decodeBase32 = fmap toShort . B32H.decodeBase32 . fromShort +{-# INLINE decodeBase32 #-} + +-- | Encode a 'ShortByteString' value as Base32hex 'Text' without padding. Note that for Base32hex, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32hex and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded' "Sun" +-- "ADQMS" +-- +encodeBase32Unpadded :: ShortByteString -> ShortText +encodeBase32Unpadded = fromShortByteStringUnsafe . encodeBase32Unpadded' +{-# INLINE encodeBase32Unpadded #-} + +-- | Encode a 'ShortByteString' value as Base32hex without padding. Note that for Base32hex, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32hex and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded' "Sun" +-- "ADQMS" +-- +encodeBase32Unpadded' :: ShortByteString -> ShortByteString +encodeBase32Unpadded' = toShort . B32H.encodeBase32Unpadded' . fromShort + +-- | Decode an unpadded Base32hex-encoded 'ShortByteString' value. Input strings are +-- required to be unpadded, and will undergo validation prior to decoding to +-- confirm. +-- +-- In general, unless unpadded Base32hex is explicitly required, it is +-- safer to call 'decodeBase32'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32Unpadded :: ShortByteString -> Either Text ShortByteString +decodeBase32Unpadded = fmap toShort . B32H.decodeBase32Unpadded . fromShort +{-# INLINE decodeBase32Unpadded #-} + +-- | Decode a padded Base32hex-encoded 'ShortByteString' value. Input strings are +-- required to be correctly padded, and will be validated prior to decoding +-- to confirm. +-- +-- In general, unless padded Base32hex is explicitly required, it is +-- safer to call 'decodeBase32'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "ADQMS" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: ShortByteString -> Either Text ShortByteString +decodeBase32Padded = fmap toShort . B32H.decodeBase32Padded . fromShort +{-# INLINE decodeBase32Padded #-} + +-- -- | Leniently decode an unpadded Base32hex-encoded 'ShortByteString'. This function +-- -- will not generate parse errors. If input data contains padding chars, +-- -- then the input will be parsed up until the first pad character. +-- -- +-- -- __Note:__ This is not RFC 4648-compliant. +-- -- +-- -- === __Examples__: +-- -- +-- -- >>> decodeBase32Lenient "PDw_Pj4=" +-- -- "<>" +-- -- +-- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" +-- -- "<>" +-- -- +-- decodeBase32Lenient :: ShortByteString -> ShortByteString +-- decodeBase32Lenient = toShort . B32H.decodeBase32Lenient . fromShort +-- {-# INLINE decodeBase32Lenient #-} + +-- | Tell whether a 'ShortByteString' is Base32hex-encoded. +-- +-- === __Examples__: +-- +-- >>> isBase32Hex "ADQMS" +-- True +-- +-- >>> isBase32Hex "ADQMS===" +-- True +-- +-- >>> isBase32Hex "ADQMS==" +-- False +-- +isBase32Hex :: ShortByteString -> Bool +isBase32Hex = B32H.isBase32Hex . fromShort +{-# INLINE isBase32Hex #-} + +-- | Tell whether a 'ShortByteString' is a valid Base32hex format. +-- +-- This will not tell you whether or not this is a correct Base32hex representation, +-- only that it conforms to the correct shape. To check whether it is a true +-- Base32 encoded 'ShortByteString' value, use 'isBase32Hex'. +-- +-- === __Examples__: +-- +-- >>> isValidBase32Hex "ADQMS" +-- True +-- +-- >>> isValidBase32Hex "ADQMS=" +-- False +-- +-- >>> isValidBase32Hex "ADQMS%" +-- False +-- +isValidBase32Hex :: ShortByteString -> Bool +isValidBase32Hex = B32H.isValidBase32Hex . fromShort +{-# INLINE isValidBase32Hex #-} diff --git a/bundled/Data/Digest/Pure/SHA.hs b/bundled/Data/Digest/Pure/SHA.hs new file mode 100644 index 0000000..255f9e2 --- /dev/null +++ b/bundled/Data/Digest/Pure/SHA.hs @@ -0,0 +1,1164 @@ +{-# LANGUAGE BangPatterns, CPP, FlexibleInstances #-} +-- |Pure implementations of the SHA suite of hash functions. The implementation +-- is basically an unoptimized translation of FIPS 180-2 into Haskell. If you're +-- looking for performance, you probably won't find it here. +module Data.Digest.Pure.SHA + ( -- * 'Digest' and related functions + Digest + , SHA1State, SHA256State, SHA512State + , showDigest + , integerDigest + , bytestringDigest + -- * Calculating hashes + , sha1 + , sha224 + , sha256 + , sha384 + , sha512 + , sha1Incremental + , completeSha1Incremental + , sha224Incremental + , completeSha224Incremental + , sha256Incremental + , completeSha256Incremental + , sha384Incremental + , completeSha384Incremental + , sha512Incremental + , completeSha512Incremental + -- * Calculating message authentication codes (MACs) + , hmacSha1 + , hmacSha224 + , hmacSha256 + , hmacSha384 + , hmacSha512 + -- * Internal routines included for testing + , toBigEndianSBS, fromBigEndianSBS + , calc_k + , padSHA1, padSHA512 + , padSHA1Chunks, padSHA512Chunks + ) + where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.Bits +import Data.ByteString.Lazy(ByteString) +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString as SBS +import Data.Char (intToDigit) +import Data.List (foldl') + +-- | An abstract datatype for digests. +newtype Digest t = Digest ByteString deriving (Eq,Ord) + +instance Show (Digest t) where + show = showDigest + +instance Binary (Digest SHA1State) where + get = Digest `fmap` getLazyByteString 20 + put (Digest bs) = putLazyByteString bs + +instance Binary (Digest SHA256State) where + get = Digest `fmap` getLazyByteString 32 + put (Digest bs) = putLazyByteString bs + +instance Binary (Digest SHA512State) where + get = Digest `fmap` getLazyByteString 64 + put (Digest bs) = putLazyByteString bs + +-- -------------------------------------------------------------------------- +-- +-- State Definitions and Initial States +-- +-- -------------------------------------------------------------------------- + +data SHA1State = SHA1S !Word32 !Word32 !Word32 !Word32 !Word32 + +initialSHA1State :: SHA1State +initialSHA1State = SHA1S 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0 + +data SHA256State = SHA256S !Word32 !Word32 !Word32 !Word32 + !Word32 !Word32 !Word32 !Word32 + +initialSHA224State :: SHA256State +initialSHA224State = SHA256S 0xc1059ed8 0x367cd507 0x3070dd17 0xf70e5939 + 0xffc00b31 0x68581511 0x64f98fa7 0xbefa4fa4 + +initialSHA256State :: SHA256State +initialSHA256State = SHA256S 0x6a09e667 0xbb67ae85 0x3c6ef372 0xa54ff53a + 0x510e527f 0x9b05688c 0x1f83d9ab 0x5be0cd19 + +data SHA512State = SHA512S !Word64 !Word64 !Word64 !Word64 + !Word64 !Word64 !Word64 !Word64 + +initialSHA384State :: SHA512State +initialSHA384State = SHA512S 0xcbbb9d5dc1059ed8 0x629a292a367cd507 + 0x9159015a3070dd17 0x152fecd8f70e5939 + 0x67332667ffc00b31 0x8eb44a8768581511 + 0xdb0c2e0d64f98fa7 0x47b5481dbefa4fa4 + +initialSHA512State :: SHA512State +initialSHA512State = SHA512S 0x6a09e667f3bcc908 0xbb67ae8584caa73b + 0x3c6ef372fe94f82b 0xa54ff53a5f1d36f1 + 0x510e527fade682d1 0x9b05688c2b3e6c1f + 0x1f83d9abfb41bd6b 0x5be0cd19137e2179 + +-- -------------------------------------------------------------------------- +-- +-- Synthesize of states to and from ByteStrings +-- +-- -------------------------------------------------------------------------- + + +synthesizeSHA1 :: SHA1State -> Put +synthesizeSHA1 (SHA1S a b c d e) = do + putWord32be a + putWord32be b + putWord32be c + putWord32be d + putWord32be e + +getSHA1 :: Get SHA1State +getSHA1 = do + a <- getWord32be + b <- getWord32be + c <- getWord32be + d <- getWord32be + e <- getWord32be + return $! SHA1S a b c d e + +synthesizeSHA224 :: SHA256State -> Put +synthesizeSHA224 (SHA256S a b c d e f g _) = do + putWord32be a + putWord32be b + putWord32be c + putWord32be d + putWord32be e + putWord32be f + putWord32be g + +synthesizeSHA256 :: SHA256State -> Put +synthesizeSHA256 (SHA256S a b c d e f g h) = do + putWord32be a + putWord32be b + putWord32be c + putWord32be d + putWord32be e + putWord32be f + putWord32be g + putWord32be h + +getSHA256 :: Get SHA256State +getSHA256 = do + a <- getWord32be + b <- getWord32be + c <- getWord32be + d <- getWord32be + e <- getWord32be + f <- getWord32be + g <- getWord32be + h <- getWord32be + return $! SHA256S a b c d e f g h + +synthesizeSHA384 :: SHA512State -> Put +synthesizeSHA384 (SHA512S a b c d e f _ _) = do + putWord64be a + putWord64be b + putWord64be c + putWord64be d + putWord64be e + putWord64be f + +synthesizeSHA512 :: SHA512State -> Put +synthesizeSHA512 (SHA512S a b c d e f g h) = do + putWord64be a + putWord64be b + putWord64be c + putWord64be d + putWord64be e + putWord64be f + putWord64be g + putWord64be h + +getSHA512 :: Get SHA512State +getSHA512 = do + a <- getWord64be + b <- getWord64be + c <- getWord64be + d <- getWord64be + e <- getWord64be + f <- getWord64be + g <- getWord64be + h <- getWord64be + return $! SHA512S a b c d e f g h + +instance Binary SHA1State where + put = synthesizeSHA1 + get = getSHA1 + +instance Binary SHA256State where + put = synthesizeSHA256 + get = getSHA256 + +instance Binary SHA512State where + put = synthesizeSHA512 + get = getSHA512 + + +-- -------------------------------------------------------------------------- +-- +-- Padding +-- +-- -------------------------------------------------------------------------- + +padSHA1 :: ByteString -> ByteString +padSHA1 = generic_pad 448 512 64 + +padSHA1Chunks :: Int -> [SBS.ByteString] +padSHA1Chunks = generic_pad_chunks 448 512 64 + +padSHA512 :: ByteString -> ByteString +padSHA512 = generic_pad 896 1024 128 + +padSHA512Chunks :: Int -> [SBS.ByteString] +padSHA512Chunks = generic_pad_chunks 896 1024 128 + +generic_pad :: Word64 -> Word64 -> Int -> ByteString -> ByteString +generic_pad a b lSize bs = + BS.fromChunks $! go 0 chunks + where + chunks = BS.toChunks bs + + -- Generates the padded ByteString at the same time it computes the length + -- of input. If the length is computed before the computation of the hash, it + -- will break the lazy evaluation of the input and no longer run in constant + -- memory space. + go !len [] = generic_pad_chunks a b lSize len + go !len (c:cs) = c : go (len + SBS.length c) cs + +generic_pad_chunks :: Word64 -> Word64 -> Int -> Int -> [SBS.ByteString] +generic_pad_chunks a b lSize len = + let lenBits = fromIntegral $ len * 8 + k = calc_k a b lenBits + -- INVARIANT: k is necessarily > 0, and (k + 1) is a multiple of 8. + kBytes = (k + 1) `div` 8 + nZeroBytes = fromIntegral $! kBytes - 1 + padLength = toBigEndianSBS lSize lenBits + in [SBS.singleton 0x80, SBS.replicate nZeroBytes 0, padLength] + +-- Given a, b, and l, calculate the smallest k such that (l + 1 + k) mod b = a. +calc_k :: Word64 -> Word64 -> Word64 -> Word64 +calc_k a b l = + if r <= -1 + then fromIntegral r + b + else fromIntegral r + where + r = toInteger a - toInteger l `mod` toInteger b - 1 + +toBigEndianSBS :: (Integral a, Bits a) => Int -> a -> SBS.ByteString +toBigEndianSBS s val = SBS.pack $ map getBits [s - 8, s - 16 .. 0] + where + getBits x = fromIntegral $ (val `shiftR` x) .&. 0xFF + +fromBigEndianSBS :: (Integral a, Bits a) => SBS.ByteString -> a +fromBigEndianSBS = + SBS.foldl (\ acc x -> (acc `shiftL` 8) + fromIntegral x) 0 + +-- -------------------------------------------------------------------------- +-- +-- SHA Functions +-- +-- -------------------------------------------------------------------------- + +{-# SPECIALIZE ch :: Word32 -> Word32 -> Word32 -> Word32 #-} +{-# SPECIALIZE ch :: Word64 -> Word64 -> Word64 -> Word64 #-} +ch :: Bits a => a -> a -> a -> a +ch x y z = (x .&. y) `xor` (complement x .&. z) + +{-# SPECIALIZE maj :: Word32 -> Word32 -> Word32 -> Word32 #-} +{-# SPECIALIZE maj :: Word64 -> Word64 -> Word64 -> Word64 #-} +maj :: Bits a => a -> a -> a -> a +maj x y z = (x .&. (y .|. z)) .|. (y .&. z) +-- note: +-- the original functions is (x & y) ^ (x & z) ^ (y & z) +-- if you fire off truth tables, this is equivalent to +-- (x & y) | (x & z) | (y & z) +-- which you can the use distribution on: +-- (x & (y | z)) | (y & z) +-- which saves us one operation. + +bsig256_0 :: Word32 -> Word32 +bsig256_0 x = rotateR x 2 `xor` rotateR x 13 `xor` rotateR x 22 + +bsig256_1 :: Word32 -> Word32 +bsig256_1 x = rotateR x 6 `xor` rotateR x 11 `xor` rotateR x 25 + +lsig256_0 :: Word32 -> Word32 +lsig256_0 x = rotateR x 7 `xor` rotateR x 18 `xor` shiftR x 3 + +lsig256_1 :: Word32 -> Word32 +lsig256_1 x = rotateR x 17 `xor` rotateR x 19 `xor` shiftR x 10 + +bsig512_0 :: Word64 -> Word64 +bsig512_0 x = rotateR x 28 `xor` rotateR x 34 `xor` rotateR x 39 + +bsig512_1 :: Word64 -> Word64 +bsig512_1 x = rotateR x 14 `xor` rotateR x 18 `xor` rotateR x 41 + +lsig512_0 :: Word64 -> Word64 +lsig512_0 x = rotateR x 1 `xor` rotateR x 8 `xor` shiftR x 7 + +lsig512_1 :: Word64 -> Word64 +lsig512_1 x = rotateR x 19 `xor` rotateR x 61 `xor` shiftR x 6 + +-- -------------------------------------------------------------------------- +-- +-- Message Schedules +-- +-- -------------------------------------------------------------------------- + +data SHA1Sched = SHA1Sched !Word32 !Word32 !Word32 !Word32 !Word32 -- 0 - 4 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 5 - 9 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 10 - 14 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 15 - 19 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 20 - 24 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 25 - 29 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 30 - 34 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 35 - 39 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 40 - 44 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 45 - 49 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 50 - 54 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 55 - 59 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 60 - 64 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 65 - 69 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 70 - 74 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 75 - 79 + +getSHA1Sched :: Get SHA1Sched +getSHA1Sched = do + w00 <- getWord32be + w01 <- getWord32be + w02 <- getWord32be + w03 <- getWord32be + w04 <- getWord32be + w05 <- getWord32be + w06 <- getWord32be + w07 <- getWord32be + w08 <- getWord32be + w09 <- getWord32be + w10 <- getWord32be + w11 <- getWord32be + w12 <- getWord32be + w13 <- getWord32be + w14 <- getWord32be + w15 <- getWord32be + let w16 = rotateL (w13 `xor` w08 `xor` w02 `xor` w00) 1 + w17 = rotateL (w14 `xor` w09 `xor` w03 `xor` w01) 1 + w18 = rotateL (w15 `xor` w10 `xor` w04 `xor` w02) 1 + w19 = rotateL (w16 `xor` w11 `xor` w05 `xor` w03) 1 + w20 = rotateL (w17 `xor` w12 `xor` w06 `xor` w04) 1 + w21 = rotateL (w18 `xor` w13 `xor` w07 `xor` w05) 1 + w22 = rotateL (w19 `xor` w14 `xor` w08 `xor` w06) 1 + w23 = rotateL (w20 `xor` w15 `xor` w09 `xor` w07) 1 + w24 = rotateL (w21 `xor` w16 `xor` w10 `xor` w08) 1 + w25 = rotateL (w22 `xor` w17 `xor` w11 `xor` w09) 1 + w26 = rotateL (w23 `xor` w18 `xor` w12 `xor` w10) 1 + w27 = rotateL (w24 `xor` w19 `xor` w13 `xor` w11) 1 + w28 = rotateL (w25 `xor` w20 `xor` w14 `xor` w12) 1 + w29 = rotateL (w26 `xor` w21 `xor` w15 `xor` w13) 1 + w30 = rotateL (w27 `xor` w22 `xor` w16 `xor` w14) 1 + w31 = rotateL (w28 `xor` w23 `xor` w17 `xor` w15) 1 + w32 = rotateL (w29 `xor` w24 `xor` w18 `xor` w16) 1 + w33 = rotateL (w30 `xor` w25 `xor` w19 `xor` w17) 1 + w34 = rotateL (w31 `xor` w26 `xor` w20 `xor` w18) 1 + w35 = rotateL (w32 `xor` w27 `xor` w21 `xor` w19) 1 + w36 = rotateL (w33 `xor` w28 `xor` w22 `xor` w20) 1 + w37 = rotateL (w34 `xor` w29 `xor` w23 `xor` w21) 1 + w38 = rotateL (w35 `xor` w30 `xor` w24 `xor` w22) 1 + w39 = rotateL (w36 `xor` w31 `xor` w25 `xor` w23) 1 + w40 = rotateL (w37 `xor` w32 `xor` w26 `xor` w24) 1 + w41 = rotateL (w38 `xor` w33 `xor` w27 `xor` w25) 1 + w42 = rotateL (w39 `xor` w34 `xor` w28 `xor` w26) 1 + w43 = rotateL (w40 `xor` w35 `xor` w29 `xor` w27) 1 + w44 = rotateL (w41 `xor` w36 `xor` w30 `xor` w28) 1 + w45 = rotateL (w42 `xor` w37 `xor` w31 `xor` w29) 1 + w46 = rotateL (w43 `xor` w38 `xor` w32 `xor` w30) 1 + w47 = rotateL (w44 `xor` w39 `xor` w33 `xor` w31) 1 + w48 = rotateL (w45 `xor` w40 `xor` w34 `xor` w32) 1 + w49 = rotateL (w46 `xor` w41 `xor` w35 `xor` w33) 1 + w50 = rotateL (w47 `xor` w42 `xor` w36 `xor` w34) 1 + w51 = rotateL (w48 `xor` w43 `xor` w37 `xor` w35) 1 + w52 = rotateL (w49 `xor` w44 `xor` w38 `xor` w36) 1 + w53 = rotateL (w50 `xor` w45 `xor` w39 `xor` w37) 1 + w54 = rotateL (w51 `xor` w46 `xor` w40 `xor` w38) 1 + w55 = rotateL (w52 `xor` w47 `xor` w41 `xor` w39) 1 + w56 = rotateL (w53 `xor` w48 `xor` w42 `xor` w40) 1 + w57 = rotateL (w54 `xor` w49 `xor` w43 `xor` w41) 1 + w58 = rotateL (w55 `xor` w50 `xor` w44 `xor` w42) 1 + w59 = rotateL (w56 `xor` w51 `xor` w45 `xor` w43) 1 + w60 = rotateL (w57 `xor` w52 `xor` w46 `xor` w44) 1 + w61 = rotateL (w58 `xor` w53 `xor` w47 `xor` w45) 1 + w62 = rotateL (w59 `xor` w54 `xor` w48 `xor` w46) 1 + w63 = rotateL (w60 `xor` w55 `xor` w49 `xor` w47) 1 + w64 = rotateL (w61 `xor` w56 `xor` w50 `xor` w48) 1 + w65 = rotateL (w62 `xor` w57 `xor` w51 `xor` w49) 1 + w66 = rotateL (w63 `xor` w58 `xor` w52 `xor` w50) 1 + w67 = rotateL (w64 `xor` w59 `xor` w53 `xor` w51) 1 + w68 = rotateL (w65 `xor` w60 `xor` w54 `xor` w52) 1 + w69 = rotateL (w66 `xor` w61 `xor` w55 `xor` w53) 1 + w70 = rotateL (w67 `xor` w62 `xor` w56 `xor` w54) 1 + w71 = rotateL (w68 `xor` w63 `xor` w57 `xor` w55) 1 + w72 = rotateL (w69 `xor` w64 `xor` w58 `xor` w56) 1 + w73 = rotateL (w70 `xor` w65 `xor` w59 `xor` w57) 1 + w74 = rotateL (w71 `xor` w66 `xor` w60 `xor` w58) 1 + w75 = rotateL (w72 `xor` w67 `xor` w61 `xor` w59) 1 + w76 = rotateL (w73 `xor` w68 `xor` w62 `xor` w60) 1 + w77 = rotateL (w74 `xor` w69 `xor` w63 `xor` w61) 1 + w78 = rotateL (w75 `xor` w70 `xor` w64 `xor` w62) 1 + w79 = rotateL (w76 `xor` w71 `xor` w65 `xor` w63) 1 + return $! SHA1Sched w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 + w10 w11 w12 w13 w14 w15 w16 w17 w18 w19 + w20 w21 w22 w23 w24 w25 w26 w27 w28 w29 + w30 w31 w32 w33 w34 w35 w36 w37 w38 w39 + w40 w41 w42 w43 w44 w45 w46 w47 w48 w49 + w50 w51 w52 w53 w54 w55 w56 w57 w58 w59 + w60 w61 w62 w63 w64 w65 w66 w67 w68 w69 + w70 w71 w72 w73 w74 w75 w76 w77 w78 w79 + +data SHA256Sched = SHA256Sched !Word32 !Word32 !Word32 !Word32 !Word32 -- 00-04 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 05-09 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 10-04 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 15-09 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 20-04 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 25-09 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 30-04 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 35-09 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 40-04 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 45-09 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 50-04 + !Word32 !Word32 !Word32 !Word32 !Word32 -- 55-09 + !Word32 !Word32 !Word32 !Word32 -- 60-63 + +getSHA256Sched :: Get SHA256Sched +getSHA256Sched = do + w00 <- getWord32be + w01 <- getWord32be + w02 <- getWord32be + w03 <- getWord32be + w04 <- getWord32be + w05 <- getWord32be + w06 <- getWord32be + w07 <- getWord32be + w08 <- getWord32be + w09 <- getWord32be + w10 <- getWord32be + w11 <- getWord32be + w12 <- getWord32be + w13 <- getWord32be + w14 <- getWord32be + w15 <- getWord32be + let w16 = lsig256_1 w14 + w09 + lsig256_0 w01 + w00 + w17 = lsig256_1 w15 + w10 + lsig256_0 w02 + w01 + w18 = lsig256_1 w16 + w11 + lsig256_0 w03 + w02 + w19 = lsig256_1 w17 + w12 + lsig256_0 w04 + w03 + w20 = lsig256_1 w18 + w13 + lsig256_0 w05 + w04 + w21 = lsig256_1 w19 + w14 + lsig256_0 w06 + w05 + w22 = lsig256_1 w20 + w15 + lsig256_0 w07 + w06 + w23 = lsig256_1 w21 + w16 + lsig256_0 w08 + w07 + w24 = lsig256_1 w22 + w17 + lsig256_0 w09 + w08 + w25 = lsig256_1 w23 + w18 + lsig256_0 w10 + w09 + w26 = lsig256_1 w24 + w19 + lsig256_0 w11 + w10 + w27 = lsig256_1 w25 + w20 + lsig256_0 w12 + w11 + w28 = lsig256_1 w26 + w21 + lsig256_0 w13 + w12 + w29 = lsig256_1 w27 + w22 + lsig256_0 w14 + w13 + w30 = lsig256_1 w28 + w23 + lsig256_0 w15 + w14 + w31 = lsig256_1 w29 + w24 + lsig256_0 w16 + w15 + w32 = lsig256_1 w30 + w25 + lsig256_0 w17 + w16 + w33 = lsig256_1 w31 + w26 + lsig256_0 w18 + w17 + w34 = lsig256_1 w32 + w27 + lsig256_0 w19 + w18 + w35 = lsig256_1 w33 + w28 + lsig256_0 w20 + w19 + w36 = lsig256_1 w34 + w29 + lsig256_0 w21 + w20 + w37 = lsig256_1 w35 + w30 + lsig256_0 w22 + w21 + w38 = lsig256_1 w36 + w31 + lsig256_0 w23 + w22 + w39 = lsig256_1 w37 + w32 + lsig256_0 w24 + w23 + w40 = lsig256_1 w38 + w33 + lsig256_0 w25 + w24 + w41 = lsig256_1 w39 + w34 + lsig256_0 w26 + w25 + w42 = lsig256_1 w40 + w35 + lsig256_0 w27 + w26 + w43 = lsig256_1 w41 + w36 + lsig256_0 w28 + w27 + w44 = lsig256_1 w42 + w37 + lsig256_0 w29 + w28 + w45 = lsig256_1 w43 + w38 + lsig256_0 w30 + w29 + w46 = lsig256_1 w44 + w39 + lsig256_0 w31 + w30 + w47 = lsig256_1 w45 + w40 + lsig256_0 w32 + w31 + w48 = lsig256_1 w46 + w41 + lsig256_0 w33 + w32 + w49 = lsig256_1 w47 + w42 + lsig256_0 w34 + w33 + w50 = lsig256_1 w48 + w43 + lsig256_0 w35 + w34 + w51 = lsig256_1 w49 + w44 + lsig256_0 w36 + w35 + w52 = lsig256_1 w50 + w45 + lsig256_0 w37 + w36 + w53 = lsig256_1 w51 + w46 + lsig256_0 w38 + w37 + w54 = lsig256_1 w52 + w47 + lsig256_0 w39 + w38 + w55 = lsig256_1 w53 + w48 + lsig256_0 w40 + w39 + w56 = lsig256_1 w54 + w49 + lsig256_0 w41 + w40 + w57 = lsig256_1 w55 + w50 + lsig256_0 w42 + w41 + w58 = lsig256_1 w56 + w51 + lsig256_0 w43 + w42 + w59 = lsig256_1 w57 + w52 + lsig256_0 w44 + w43 + w60 = lsig256_1 w58 + w53 + lsig256_0 w45 + w44 + w61 = lsig256_1 w59 + w54 + lsig256_0 w46 + w45 + w62 = lsig256_1 w60 + w55 + lsig256_0 w47 + w46 + w63 = lsig256_1 w61 + w56 + lsig256_0 w48 + w47 + return $! SHA256Sched w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 + w10 w11 w12 w13 w14 w15 w16 w17 w18 w19 + w20 w21 w22 w23 w24 w25 w26 w27 w28 w29 + w30 w31 w32 w33 w34 w35 w36 w37 w38 w39 + w40 w41 w42 w43 w44 w45 w46 w47 w48 w49 + w50 w51 w52 w53 w54 w55 w56 w57 w58 w59 + w60 w61 w62 w63 + +data SHA512Sched = SHA512Sched !Word64 !Word64 !Word64 !Word64 !Word64 -- 0- 4 + !Word64 !Word64 !Word64 !Word64 !Word64 -- 5- 9 + !Word64 !Word64 !Word64 !Word64 !Word64 -- 10-14 + !Word64 !Word64 !Word64 !Word64 !Word64 -- 15-19 + !Word64 !Word64 !Word64 !Word64 !Word64 -- 20-24 + !Word64 !Word64 !Word64 !Word64 !Word64 -- 25-29 + !Word64 !Word64 !Word64 !Word64 !Word64 -- 30-34 + !Word64 !Word64 !Word64 !Word64 !Word64 -- 35-39 + !Word64 !Word64 !Word64 !Word64 !Word64 -- 40-44 + !Word64 !Word64 !Word64 !Word64 !Word64 -- 45-49 + !Word64 !Word64 !Word64 !Word64 !Word64 -- 50-54 + !Word64 !Word64 !Word64 !Word64 !Word64 -- 55-59 + !Word64 !Word64 !Word64 !Word64 !Word64 -- 60-64 + !Word64 !Word64 !Word64 !Word64 !Word64 -- 65-69 + !Word64 !Word64 !Word64 !Word64 !Word64 -- 70-74 + !Word64 !Word64 !Word64 !Word64 !Word64 -- 75-79 + +getSHA512Sched :: Get SHA512Sched +getSHA512Sched = do + w00 <- getWord64be + w01 <- getWord64be + w02 <- getWord64be + w03 <- getWord64be + w04 <- getWord64be + w05 <- getWord64be + w06 <- getWord64be + w07 <- getWord64be + w08 <- getWord64be + w09 <- getWord64be + w10 <- getWord64be + w11 <- getWord64be + w12 <- getWord64be + w13 <- getWord64be + w14 <- getWord64be + w15 <- getWord64be + let w16 = lsig512_1 w14 + w09 + lsig512_0 w01 + w00 + w17 = lsig512_1 w15 + w10 + lsig512_0 w02 + w01 + w18 = lsig512_1 w16 + w11 + lsig512_0 w03 + w02 + w19 = lsig512_1 w17 + w12 + lsig512_0 w04 + w03 + w20 = lsig512_1 w18 + w13 + lsig512_0 w05 + w04 + w21 = lsig512_1 w19 + w14 + lsig512_0 w06 + w05 + w22 = lsig512_1 w20 + w15 + lsig512_0 w07 + w06 + w23 = lsig512_1 w21 + w16 + lsig512_0 w08 + w07 + w24 = lsig512_1 w22 + w17 + lsig512_0 w09 + w08 + w25 = lsig512_1 w23 + w18 + lsig512_0 w10 + w09 + w26 = lsig512_1 w24 + w19 + lsig512_0 w11 + w10 + w27 = lsig512_1 w25 + w20 + lsig512_0 w12 + w11 + w28 = lsig512_1 w26 + w21 + lsig512_0 w13 + w12 + w29 = lsig512_1 w27 + w22 + lsig512_0 w14 + w13 + w30 = lsig512_1 w28 + w23 + lsig512_0 w15 + w14 + w31 = lsig512_1 w29 + w24 + lsig512_0 w16 + w15 + w32 = lsig512_1 w30 + w25 + lsig512_0 w17 + w16 + w33 = lsig512_1 w31 + w26 + lsig512_0 w18 + w17 + w34 = lsig512_1 w32 + w27 + lsig512_0 w19 + w18 + w35 = lsig512_1 w33 + w28 + lsig512_0 w20 + w19 + w36 = lsig512_1 w34 + w29 + lsig512_0 w21 + w20 + w37 = lsig512_1 w35 + w30 + lsig512_0 w22 + w21 + w38 = lsig512_1 w36 + w31 + lsig512_0 w23 + w22 + w39 = lsig512_1 w37 + w32 + lsig512_0 w24 + w23 + w40 = lsig512_1 w38 + w33 + lsig512_0 w25 + w24 + w41 = lsig512_1 w39 + w34 + lsig512_0 w26 + w25 + w42 = lsig512_1 w40 + w35 + lsig512_0 w27 + w26 + w43 = lsig512_1 w41 + w36 + lsig512_0 w28 + w27 + w44 = lsig512_1 w42 + w37 + lsig512_0 w29 + w28 + w45 = lsig512_1 w43 + w38 + lsig512_0 w30 + w29 + w46 = lsig512_1 w44 + w39 + lsig512_0 w31 + w30 + w47 = lsig512_1 w45 + w40 + lsig512_0 w32 + w31 + w48 = lsig512_1 w46 + w41 + lsig512_0 w33 + w32 + w49 = lsig512_1 w47 + w42 + lsig512_0 w34 + w33 + w50 = lsig512_1 w48 + w43 + lsig512_0 w35 + w34 + w51 = lsig512_1 w49 + w44 + lsig512_0 w36 + w35 + w52 = lsig512_1 w50 + w45 + lsig512_0 w37 + w36 + w53 = lsig512_1 w51 + w46 + lsig512_0 w38 + w37 + w54 = lsig512_1 w52 + w47 + lsig512_0 w39 + w38 + w55 = lsig512_1 w53 + w48 + lsig512_0 w40 + w39 + w56 = lsig512_1 w54 + w49 + lsig512_0 w41 + w40 + w57 = lsig512_1 w55 + w50 + lsig512_0 w42 + w41 + w58 = lsig512_1 w56 + w51 + lsig512_0 w43 + w42 + w59 = lsig512_1 w57 + w52 + lsig512_0 w44 + w43 + w60 = lsig512_1 w58 + w53 + lsig512_0 w45 + w44 + w61 = lsig512_1 w59 + w54 + lsig512_0 w46 + w45 + w62 = lsig512_1 w60 + w55 + lsig512_0 w47 + w46 + w63 = lsig512_1 w61 + w56 + lsig512_0 w48 + w47 + w64 = lsig512_1 w62 + w57 + lsig512_0 w49 + w48 + w65 = lsig512_1 w63 + w58 + lsig512_0 w50 + w49 + w66 = lsig512_1 w64 + w59 + lsig512_0 w51 + w50 + w67 = lsig512_1 w65 + w60 + lsig512_0 w52 + w51 + w68 = lsig512_1 w66 + w61 + lsig512_0 w53 + w52 + w69 = lsig512_1 w67 + w62 + lsig512_0 w54 + w53 + w70 = lsig512_1 w68 + w63 + lsig512_0 w55 + w54 + w71 = lsig512_1 w69 + w64 + lsig512_0 w56 + w55 + w72 = lsig512_1 w70 + w65 + lsig512_0 w57 + w56 + w73 = lsig512_1 w71 + w66 + lsig512_0 w58 + w57 + w74 = lsig512_1 w72 + w67 + lsig512_0 w59 + w58 + w75 = lsig512_1 w73 + w68 + lsig512_0 w60 + w59 + w76 = lsig512_1 w74 + w69 + lsig512_0 w61 + w60 + w77 = lsig512_1 w75 + w70 + lsig512_0 w62 + w61 + w78 = lsig512_1 w76 + w71 + lsig512_0 w63 + w62 + w79 = lsig512_1 w77 + w72 + lsig512_0 w64 + w63 + return $! SHA512Sched w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 + w10 w11 w12 w13 w14 w15 w16 w17 w18 w19 + w20 w21 w22 w23 w24 w25 w26 w27 w28 w29 + w30 w31 w32 w33 w34 w35 w36 w37 w38 w39 + w40 w41 w42 w43 w44 w45 w46 w47 w48 w49 + w50 w51 w52 w53 w54 w55 w56 w57 w58 w59 + w60 w61 w62 w63 w64 w65 w66 w67 w68 w69 + w70 w71 w72 w73 w74 w75 w76 w77 w78 w79 + +-- -------------------------------------------------------------------------- +-- +-- SHA Block Processors +-- +-- -------------------------------------------------------------------------- + +processSHA1Block :: SHA1State -> Get SHA1State +processSHA1Block s00@(SHA1S a00 b00 c00 d00 e00) = do + (SHA1Sched w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 + w10 w11 w12 w13 w14 w15 w16 w17 w18 w19 + w20 w21 w22 w23 w24 w25 w26 w27 w28 w29 + w30 w31 w32 w33 w34 w35 w36 w37 w38 w39 + w40 w41 w42 w43 w44 w45 w46 w47 w48 w49 + w50 w51 w52 w53 w54 w55 w56 w57 w58 w59 + w60 w61 w62 w63 w64 w65 w66 w67 w68 w69 + w70 w71 w72 w73 w74 w75 w76 w77 w78 w79) <- getSHA1Sched + let s01 = step1_ch s00 0x5a827999 w00 + s02 = step1_ch s01 0x5a827999 w01 + s03 = step1_ch s02 0x5a827999 w02 + s04 = step1_ch s03 0x5a827999 w03 + s05 = step1_ch s04 0x5a827999 w04 + s06 = step1_ch s05 0x5a827999 w05 + s07 = step1_ch s06 0x5a827999 w06 + s08 = step1_ch s07 0x5a827999 w07 + s09 = step1_ch s08 0x5a827999 w08 + s10 = step1_ch s09 0x5a827999 w09 + s11 = step1_ch s10 0x5a827999 w10 + s12 = step1_ch s11 0x5a827999 w11 + s13 = step1_ch s12 0x5a827999 w12 + s14 = step1_ch s13 0x5a827999 w13 + s15 = step1_ch s14 0x5a827999 w14 + s16 = step1_ch s15 0x5a827999 w15 + s17 = step1_ch s16 0x5a827999 w16 + s18 = step1_ch s17 0x5a827999 w17 + s19 = step1_ch s18 0x5a827999 w18 + s20 = step1_ch s19 0x5a827999 w19 + s21 = step1_par s20 0x6ed9eba1 w20 + s22 = step1_par s21 0x6ed9eba1 w21 + s23 = step1_par s22 0x6ed9eba1 w22 + s24 = step1_par s23 0x6ed9eba1 w23 + s25 = step1_par s24 0x6ed9eba1 w24 + s26 = step1_par s25 0x6ed9eba1 w25 + s27 = step1_par s26 0x6ed9eba1 w26 + s28 = step1_par s27 0x6ed9eba1 w27 + s29 = step1_par s28 0x6ed9eba1 w28 + s30 = step1_par s29 0x6ed9eba1 w29 + s31 = step1_par s30 0x6ed9eba1 w30 + s32 = step1_par s31 0x6ed9eba1 w31 + s33 = step1_par s32 0x6ed9eba1 w32 + s34 = step1_par s33 0x6ed9eba1 w33 + s35 = step1_par s34 0x6ed9eba1 w34 + s36 = step1_par s35 0x6ed9eba1 w35 + s37 = step1_par s36 0x6ed9eba1 w36 + s38 = step1_par s37 0x6ed9eba1 w37 + s39 = step1_par s38 0x6ed9eba1 w38 + s40 = step1_par s39 0x6ed9eba1 w39 + s41 = step1_maj s40 0x8f1bbcdc w40 + s42 = step1_maj s41 0x8f1bbcdc w41 + s43 = step1_maj s42 0x8f1bbcdc w42 + s44 = step1_maj s43 0x8f1bbcdc w43 + s45 = step1_maj s44 0x8f1bbcdc w44 + s46 = step1_maj s45 0x8f1bbcdc w45 + s47 = step1_maj s46 0x8f1bbcdc w46 + s48 = step1_maj s47 0x8f1bbcdc w47 + s49 = step1_maj s48 0x8f1bbcdc w48 + s50 = step1_maj s49 0x8f1bbcdc w49 + s51 = step1_maj s50 0x8f1bbcdc w50 + s52 = step1_maj s51 0x8f1bbcdc w51 + s53 = step1_maj s52 0x8f1bbcdc w52 + s54 = step1_maj s53 0x8f1bbcdc w53 + s55 = step1_maj s54 0x8f1bbcdc w54 + s56 = step1_maj s55 0x8f1bbcdc w55 + s57 = step1_maj s56 0x8f1bbcdc w56 + s58 = step1_maj s57 0x8f1bbcdc w57 + s59 = step1_maj s58 0x8f1bbcdc w58 + s60 = step1_maj s59 0x8f1bbcdc w59 + s61 = step1_par s60 0xca62c1d6 w60 + s62 = step1_par s61 0xca62c1d6 w61 + s63 = step1_par s62 0xca62c1d6 w62 + s64 = step1_par s63 0xca62c1d6 w63 + s65 = step1_par s64 0xca62c1d6 w64 + s66 = step1_par s65 0xca62c1d6 w65 + s67 = step1_par s66 0xca62c1d6 w66 + s68 = step1_par s67 0xca62c1d6 w67 + s69 = step1_par s68 0xca62c1d6 w68 + s70 = step1_par s69 0xca62c1d6 w69 + s71 = step1_par s70 0xca62c1d6 w70 + s72 = step1_par s71 0xca62c1d6 w71 + s73 = step1_par s72 0xca62c1d6 w72 + s74 = step1_par s73 0xca62c1d6 w73 + s75 = step1_par s74 0xca62c1d6 w74 + s76 = step1_par s75 0xca62c1d6 w75 + s77 = step1_par s76 0xca62c1d6 w76 + s78 = step1_par s77 0xca62c1d6 w77 + s79 = step1_par s78 0xca62c1d6 w78 + s80 = step1_par s79 0xca62c1d6 w79 + SHA1S a80 b80 c80 d80 e80 = s80 + return $! SHA1S (a00 + a80) (b00 + b80) (c00 + c80) (d00 + d80) (e00 + e80) + +{-# INLINE step1_ch #-} +step1_ch :: SHA1State -> Word32 -> Word32 -> SHA1State +step1_ch !(SHA1S a b c d e) k w = SHA1S a' b' c' d' e' + where a' = rotateL a 5 + ((b .&. c) `xor` (complement b .&. d)) + e + k + w + b' = a + c' = rotateL b 30 + d' = c + e' = d + +{-# INLINE step1_par #-} +step1_par :: SHA1State -> Word32 -> Word32 -> SHA1State +step1_par !(SHA1S a b c d e) k w = SHA1S a' b' c' d' e' + where a' = rotateL a 5 + (b `xor` c `xor` d) + e + k + w + b' = a + c' = rotateL b 30 + d' = c + e' = d + +{-# INLINE step1_maj #-} +step1_maj :: SHA1State -> Word32 -> Word32 -> SHA1State +step1_maj !(SHA1S a b c d e) k w = SHA1S a' b' c' d' e' + where a' = rotateL a 5 + ((b .&. (c .|. d)) .|. (c .&. d)) + e + k + w + b' = a + c' = rotateL b 30 + d' = c + e' = d +-- See the note on maj, above + +processSHA256Block :: SHA256State -> Get SHA256State +processSHA256Block !s00@(SHA256S a00 b00 c00 d00 e00 f00 g00 h00) = do + (SHA256Sched w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 + w10 w11 w12 w13 w14 w15 w16 w17 w18 w19 + w20 w21 w22 w23 w24 w25 w26 w27 w28 w29 + w30 w31 w32 w33 w34 w35 w36 w37 w38 w39 + w40 w41 w42 w43 w44 w45 w46 w47 w48 w49 + w50 w51 w52 w53 w54 w55 w56 w57 w58 w59 + w60 w61 w62 w63) <- getSHA256Sched + let s01 = step256 s00 0x428a2f98 w00 + s02 = step256 s01 0x71374491 w01 + s03 = step256 s02 0xb5c0fbcf w02 + s04 = step256 s03 0xe9b5dba5 w03 + s05 = step256 s04 0x3956c25b w04 + s06 = step256 s05 0x59f111f1 w05 + s07 = step256 s06 0x923f82a4 w06 + s08 = step256 s07 0xab1c5ed5 w07 + s09 = step256 s08 0xd807aa98 w08 + s10 = step256 s09 0x12835b01 w09 + s11 = step256 s10 0x243185be w10 + s12 = step256 s11 0x550c7dc3 w11 + s13 = step256 s12 0x72be5d74 w12 + s14 = step256 s13 0x80deb1fe w13 + s15 = step256 s14 0x9bdc06a7 w14 + s16 = step256 s15 0xc19bf174 w15 + s17 = step256 s16 0xe49b69c1 w16 + s18 = step256 s17 0xefbe4786 w17 + s19 = step256 s18 0x0fc19dc6 w18 + s20 = step256 s19 0x240ca1cc w19 + s21 = step256 s20 0x2de92c6f w20 + s22 = step256 s21 0x4a7484aa w21 + s23 = step256 s22 0x5cb0a9dc w22 + s24 = step256 s23 0x76f988da w23 + s25 = step256 s24 0x983e5152 w24 + s26 = step256 s25 0xa831c66d w25 + s27 = step256 s26 0xb00327c8 w26 + s28 = step256 s27 0xbf597fc7 w27 + s29 = step256 s28 0xc6e00bf3 w28 + s30 = step256 s29 0xd5a79147 w29 + s31 = step256 s30 0x06ca6351 w30 + s32 = step256 s31 0x14292967 w31 + s33 = step256 s32 0x27b70a85 w32 + s34 = step256 s33 0x2e1b2138 w33 + s35 = step256 s34 0x4d2c6dfc w34 + s36 = step256 s35 0x53380d13 w35 + s37 = step256 s36 0x650a7354 w36 + s38 = step256 s37 0x766a0abb w37 + s39 = step256 s38 0x81c2c92e w38 + s40 = step256 s39 0x92722c85 w39 + s41 = step256 s40 0xa2bfe8a1 w40 + s42 = step256 s41 0xa81a664b w41 + s43 = step256 s42 0xc24b8b70 w42 + s44 = step256 s43 0xc76c51a3 w43 + s45 = step256 s44 0xd192e819 w44 + s46 = step256 s45 0xd6990624 w45 + s47 = step256 s46 0xf40e3585 w46 + s48 = step256 s47 0x106aa070 w47 + s49 = step256 s48 0x19a4c116 w48 + s50 = step256 s49 0x1e376c08 w49 + s51 = step256 s50 0x2748774c w50 + s52 = step256 s51 0x34b0bcb5 w51 + s53 = step256 s52 0x391c0cb3 w52 + s54 = step256 s53 0x4ed8aa4a w53 + s55 = step256 s54 0x5b9cca4f w54 + s56 = step256 s55 0x682e6ff3 w55 + s57 = step256 s56 0x748f82ee w56 + s58 = step256 s57 0x78a5636f w57 + s59 = step256 s58 0x84c87814 w58 + s60 = step256 s59 0x8cc70208 w59 + s61 = step256 s60 0x90befffa w60 + s62 = step256 s61 0xa4506ceb w61 + s63 = step256 s62 0xbef9a3f7 w62 + s64 = step256 s63 0xc67178f2 w63 + SHA256S a64 b64 c64 d64 e64 f64 g64 h64 = s64 + return $! SHA256S (a00 + a64) (b00 + b64) (c00 + c64) (d00 + d64) + (e00 + e64) (f00 + f64) (g00 + g64) (h00 + h64) + +{-# INLINE step256 #-} +step256 :: SHA256State -> Word32 -> Word32 -> SHA256State +step256 !(SHA256S a b c d e f g h) k w = SHA256S a' b' c' d' e' f' g' h' + where + t1 = h + bsig256_1 e + ch e f g + k + w + t2 = bsig256_0 a + maj a b c + h' = g + g' = f + f' = e + e' = d + t1 + d' = c + c' = b + b' = a + a' = t1 + t2 + +processSHA512Block :: SHA512State -> Get SHA512State +processSHA512Block !s00@(SHA512S a00 b00 c00 d00 e00 f00 g00 h00) = do + (SHA512Sched w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 + w10 w11 w12 w13 w14 w15 w16 w17 w18 w19 + w20 w21 w22 w23 w24 w25 w26 w27 w28 w29 + w30 w31 w32 w33 w34 w35 w36 w37 w38 w39 + w40 w41 w42 w43 w44 w45 w46 w47 w48 w49 + w50 w51 w52 w53 w54 w55 w56 w57 w58 w59 + w60 w61 w62 w63 w64 w65 w66 w67 w68 w69 + w70 w71 w72 w73 w74 w75 w76 w77 w78 w79) <- getSHA512Sched + let s01 = step512 s00 0x428a2f98d728ae22 w00 + s02 = step512 s01 0x7137449123ef65cd w01 + s03 = step512 s02 0xb5c0fbcfec4d3b2f w02 + s04 = step512 s03 0xe9b5dba58189dbbc w03 + s05 = step512 s04 0x3956c25bf348b538 w04 + s06 = step512 s05 0x59f111f1b605d019 w05 + s07 = step512 s06 0x923f82a4af194f9b w06 + s08 = step512 s07 0xab1c5ed5da6d8118 w07 + s09 = step512 s08 0xd807aa98a3030242 w08 + s10 = step512 s09 0x12835b0145706fbe w09 + s11 = step512 s10 0x243185be4ee4b28c w10 + s12 = step512 s11 0x550c7dc3d5ffb4e2 w11 + s13 = step512 s12 0x72be5d74f27b896f w12 + s14 = step512 s13 0x80deb1fe3b1696b1 w13 + s15 = step512 s14 0x9bdc06a725c71235 w14 + s16 = step512 s15 0xc19bf174cf692694 w15 + s17 = step512 s16 0xe49b69c19ef14ad2 w16 + s18 = step512 s17 0xefbe4786384f25e3 w17 + s19 = step512 s18 0x0fc19dc68b8cd5b5 w18 + s20 = step512 s19 0x240ca1cc77ac9c65 w19 + s21 = step512 s20 0x2de92c6f592b0275 w20 + s22 = step512 s21 0x4a7484aa6ea6e483 w21 + s23 = step512 s22 0x5cb0a9dcbd41fbd4 w22 + s24 = step512 s23 0x76f988da831153b5 w23 + s25 = step512 s24 0x983e5152ee66dfab w24 + s26 = step512 s25 0xa831c66d2db43210 w25 + s27 = step512 s26 0xb00327c898fb213f w26 + s28 = step512 s27 0xbf597fc7beef0ee4 w27 + s29 = step512 s28 0xc6e00bf33da88fc2 w28 + s30 = step512 s29 0xd5a79147930aa725 w29 + s31 = step512 s30 0x06ca6351e003826f w30 + s32 = step512 s31 0x142929670a0e6e70 w31 + s33 = step512 s32 0x27b70a8546d22ffc w32 + s34 = step512 s33 0x2e1b21385c26c926 w33 + s35 = step512 s34 0x4d2c6dfc5ac42aed w34 + s36 = step512 s35 0x53380d139d95b3df w35 + s37 = step512 s36 0x650a73548baf63de w36 + s38 = step512 s37 0x766a0abb3c77b2a8 w37 + s39 = step512 s38 0x81c2c92e47edaee6 w38 + s40 = step512 s39 0x92722c851482353b w39 + s41 = step512 s40 0xa2bfe8a14cf10364 w40 + s42 = step512 s41 0xa81a664bbc423001 w41 + s43 = step512 s42 0xc24b8b70d0f89791 w42 + s44 = step512 s43 0xc76c51a30654be30 w43 + s45 = step512 s44 0xd192e819d6ef5218 w44 + s46 = step512 s45 0xd69906245565a910 w45 + s47 = step512 s46 0xf40e35855771202a w46 + s48 = step512 s47 0x106aa07032bbd1b8 w47 + s49 = step512 s48 0x19a4c116b8d2d0c8 w48 + s50 = step512 s49 0x1e376c085141ab53 w49 + s51 = step512 s50 0x2748774cdf8eeb99 w50 + s52 = step512 s51 0x34b0bcb5e19b48a8 w51 + s53 = step512 s52 0x391c0cb3c5c95a63 w52 + s54 = step512 s53 0x4ed8aa4ae3418acb w53 + s55 = step512 s54 0x5b9cca4f7763e373 w54 + s56 = step512 s55 0x682e6ff3d6b2b8a3 w55 + s57 = step512 s56 0x748f82ee5defb2fc w56 + s58 = step512 s57 0x78a5636f43172f60 w57 + s59 = step512 s58 0x84c87814a1f0ab72 w58 + s60 = step512 s59 0x8cc702081a6439ec w59 + s61 = step512 s60 0x90befffa23631e28 w60 + s62 = step512 s61 0xa4506cebde82bde9 w61 + s63 = step512 s62 0xbef9a3f7b2c67915 w62 + s64 = step512 s63 0xc67178f2e372532b w63 + s65 = step512 s64 0xca273eceea26619c w64 + s66 = step512 s65 0xd186b8c721c0c207 w65 + s67 = step512 s66 0xeada7dd6cde0eb1e w66 + s68 = step512 s67 0xf57d4f7fee6ed178 w67 + s69 = step512 s68 0x06f067aa72176fba w68 + s70 = step512 s69 0x0a637dc5a2c898a6 w69 + s71 = step512 s70 0x113f9804bef90dae w70 + s72 = step512 s71 0x1b710b35131c471b w71 + s73 = step512 s72 0x28db77f523047d84 w72 + s74 = step512 s73 0x32caab7b40c72493 w73 + s75 = step512 s74 0x3c9ebe0a15c9bebc w74 + s76 = step512 s75 0x431d67c49c100d4c w75 + s77 = step512 s76 0x4cc5d4becb3e42b6 w76 + s78 = step512 s77 0x597f299cfc657e2a w77 + s79 = step512 s78 0x5fcb6fab3ad6faec w78 + s80 = step512 s79 0x6c44198c4a475817 w79 + SHA512S a80 b80 c80 d80 e80 f80 g80 h80 = s80 + return $! SHA512S (a00 + a80) (b00 + b80) (c00 + c80) (d00 + d80) + (e00 + e80) (f00 + f80) (g00 + g80) (h00 + h80) + +{-# INLINE step512 #-} +step512 :: SHA512State -> Word64 -> Word64 -> SHA512State +step512 !(SHA512S a b c d e f g h) k w = SHA512S a' b' c' d' e' f' g' h' + where + t1 = h + bsig512_1 e + ch e f g + k + w + t2 = bsig512_0 a + maj a b c + h' = g + g' = f + f' = e + e' = d + t1 + d' = c + c' = b + b' = a + a' = t1 + t2 + +-- -------------------------------------------------------------------------- +-- +-- Run the routines +-- +-- -------------------------------------------------------------------------- + +runSHA :: a -> (a -> Get a) -> ByteString -> a +runSHA s nextChunk input = runGet (getAll s) input + where + getAll s_in = do + done <- isEmpty + if done + then return s_in + else nextChunk s_in >>= getAll + +runSHAIncremental :: a -> (a -> Get a) -> Decoder a +runSHAIncremental s nextChunk = runGetIncremental (getAll s) + where + getAll s_in = do + done <- isEmpty + if done + then return s_in + else nextChunk s_in >>= getAll + +generic_complete :: (t -> [SBS.ByteString]) -> (a -> Put) -> Decoder a -> t + -> Digest a +generic_complete pad synthesize decoder len = + let decoder' = pushEndOfInput $ foldl' pushChunk decoder $ pad len + in case decoder' of + Fail _ _ _ -> error "Decoder is in Fail state." + Partial _ -> error "Decoder is in Partial state." + Done _ _ x -> Digest $ runPut $! synthesize x + +-- |Compute the SHA-1 hash of the given ByteString. The output is guaranteed +-- to be exactly 160 bits, or 20 bytes, long. This is a good default for +-- programs that need a good, but not necessarily hyper-secure, hash function. +sha1 :: ByteString -> Digest SHA1State +sha1 bs_in = Digest bs_out + where + bs_pad = padSHA1 bs_in + fstate = runSHA initialSHA1State processSHA1Block bs_pad + bs_out = runPut $! synthesizeSHA1 fstate + +-- |Similar to `sha1` but use an incremental interface. When the decoder has +-- been completely fed, `completeSha1Incremental` must be used so it can +-- finish successfully. +sha1Incremental :: Decoder SHA1State +sha1Incremental = runSHAIncremental initialSHA1State processSHA1Block + +completeSha1Incremental :: Decoder SHA1State -> Int -> Digest SHA1State +completeSha1Incremental = generic_complete padSHA1Chunks synthesizeSHA1 + +-- |Compute the SHA-224 hash of the given ByteString. Note that SHA-224 and +-- SHA-384 differ only slightly from SHA-256 and SHA-512, and use truncated +-- versions of the resulting hashes. So using 224/384 may not, in fact, save +-- you very much ... +sha224 :: ByteString -> Digest SHA256State +sha224 bs_in = Digest bs_out + where + bs_pad = padSHA1 bs_in + fstate = runSHA initialSHA224State processSHA256Block bs_pad + bs_out = runPut $! synthesizeSHA224 fstate + +-- |Similar to `sha224` but use an incremental interface. When the decoder has +-- been completely fed, `completeSha224Incremental` must be used so it can +-- finish successfully. +sha224Incremental :: Decoder SHA256State +sha224Incremental = runSHAIncremental initialSHA224State processSHA256Block + +completeSha224Incremental :: Decoder SHA256State -> Int -> Digest SHA256State +completeSha224Incremental = generic_complete padSHA1Chunks synthesizeSHA224 + +-- |Compute the SHA-256 hash of the given ByteString. The output is guaranteed +-- to be exactly 256 bits, or 32 bytes, long. If your security requirements +-- are pretty serious, this is a good choice. For truly significant security +-- concerns, however, you might try one of the bigger options. +sha256 :: ByteString -> Digest SHA256State +sha256 bs_in = Digest bs_out + where + bs_pad = padSHA1 bs_in + fstate = runSHA initialSHA256State processSHA256Block bs_pad + bs_out = runPut $! synthesizeSHA256 fstate + +-- |Similar to `sha256` but use an incremental interface. When the decoder has +-- been completely fed, `completeSha256Incremental` must be used so it can +-- finish successfully. +sha256Incremental :: Decoder SHA256State +sha256Incremental = runSHAIncremental initialSHA256State processSHA256Block + +completeSha256Incremental :: Decoder SHA256State -> Int -> Digest SHA256State +completeSha256Incremental = generic_complete padSHA1Chunks synthesizeSHA256 + +-- |Compute the SHA-384 hash of the given ByteString. Yup, you guessed it, +-- the output will be exactly 384 bits, or 48 bytes, long. +sha384 :: ByteString -> Digest SHA512State +sha384 bs_in = Digest bs_out + where + bs_pad = padSHA512 bs_in + fstate = runSHA initialSHA384State processSHA512Block bs_pad + bs_out = runPut $! synthesizeSHA384 fstate + +-- |Similar to `sha384` but use an incremental interface. When the decoder has +-- been completely fed, `completeSha384Incremental` must be used so it can +-- finish successfully. +sha384Incremental :: Decoder SHA512State +sha384Incremental = runSHAIncremental initialSHA384State processSHA512Block + +completeSha384Incremental :: Decoder SHA512State -> Int -> Digest SHA512State +completeSha384Incremental = generic_complete padSHA512Chunks synthesizeSHA384 + +-- |For those for whom only the biggest hashes will do, this computes the +-- SHA-512 hash of the given ByteString. The output will be 64 bytes, or +-- 512 bits, long. +sha512 :: ByteString -> Digest SHA512State +sha512 bs_in = Digest bs_out + where + bs_pad = padSHA512 bs_in + fstate = runSHA initialSHA512State processSHA512Block bs_pad + bs_out = runPut $! synthesizeSHA512 fstate + +-- |Similar to `sha512` but use an incremental interface. When the decoder has +-- been completely fed, `completeSha512Incremental` must be used so it can +-- finish successfully. +sha512Incremental :: Decoder SHA512State +sha512Incremental = runSHAIncremental initialSHA512State processSHA512Block + +completeSha512Incremental :: Decoder SHA512State -> Int -> Digest SHA512State +completeSha512Incremental = generic_complete padSHA512Chunks synthesizeSHA512 + +-- -------------------------------------------------------------------------- + +-- | Compute an HMAC using SHA-1. +hmacSha1 + :: ByteString -- ^ secret key + -> ByteString -- ^ message + -> Digest SHA1State -- ^ SHA-1 MAC +hmacSha1 = hmac sha1 64 + +-- | Compute an HMAC using SHA-224. +hmacSha224 + :: ByteString -- ^ secret key + -> ByteString -- ^ message + -> Digest SHA256State -- ^ SHA-224 MAC +hmacSha224 = hmac sha224 64 + +-- | Compute an HMAC using SHA-256. +hmacSha256 + :: ByteString -- ^ secret key + -> ByteString -- ^ message + -> Digest SHA256State -- ^ SHA-256 MAC +hmacSha256 = hmac sha256 64 + +-- | Compute an HMAC using SHA-384. +hmacSha384 + :: ByteString -- ^ secret key + -> ByteString -- ^ message + -> Digest SHA512State -- ^ SHA-384 MAC +hmacSha384 = hmac sha384 128 + +-- | Compute an HMAC using SHA-512. +hmacSha512 + :: ByteString -- ^ secret key + -> ByteString -- ^ message + -> Digest SHA512State -- ^ SHA-512 MAC +hmacSha512 = hmac sha512 128 + +-- -------------------------------------------------------------------------- + +hmac :: (ByteString -> Digest t) -> Int -> ByteString -> ByteString -> Digest t +hmac f bl k m = f (BS.append opad (bytestringDigest (f (BS.append ipad m)))) + where + opad = BS.map (xor ov) k' + ipad = BS.map (xor iv) k' + ov = 0x5c :: Word8 + iv = 0x36 :: Word8 + + k' = BS.append kt pad + where + kt = if kn > bn then bytestringDigest (f k) else k + pad = BS.replicate (bn - ktn) 0 + kn = fromIntegral (BS.length k) + ktn = fromIntegral (BS.length kt) + bn = fromIntegral bl + +-- -------------------------------------------------------------------------- +-- +-- OTHER +-- +-- -------------------------------------------------------------------------- + + +-- | Convert a digest to a string. +-- The digest is rendered as fixed with hexadecimal number. +showDigest :: Digest t -> String +showDigest (Digest bs) = showDigestBS bs + +-- |Prints out a bytestring in hexadecimal. Just for convenience. +showDigestBS :: ByteString -> String +showDigestBS bs = foldr paddedShowHex [] (BS.unpack bs) + where + paddedShowHex x xs = intToDigit (fromIntegral (x `shiftR` 4)) + : intToDigit (fromIntegral (x .&. 0xf)) + : xs + +-- | Convert a digest to an Integer. +integerDigest :: Digest t -> Integer +integerDigest (Digest bs) = BS.foldl' addShift 0 bs + where addShift n y = (n `shiftL` 8) .|. fromIntegral y + +-- | Convert a digest to a ByteString. +bytestringDigest :: Digest t -> ByteString +bytestringDigest (Digest bs) = bs diff --git a/bundled/Data/Memory/Encoding/Base16.hs b/bundled/Data/Memory/Encoding/Base16.hs new file mode 100644 index 0000000..9c4e6c4 --- /dev/null +++ b/bundled/Data/Memory/Encoding/Base16.hs @@ -0,0 +1,176 @@ +-- | +-- Module : Data.Memory.Encoding.Base16 +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Low-level Base16 encoding and decoding. +-- +-- If you just want to encode or decode some bytes, you probably want to use +-- the "Data.ByteArray.Encoding" module. +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Rank2Types #-} +module Data.Memory.Encoding.Base16 + ( showHexadecimal + , toHexadecimal + , fromHexadecimal + ) where + +import Data.Memory.Internal.Compat +import Data.Word +import Basement.Bits +import Basement.IntegralConv +import GHC.Prim +import GHC.Types +import GHC.Word +import GHC.Char (chr) +import Control.Monad +import Foreign.Storable +import Foreign.Ptr (Ptr) + +-- | Transform a raw memory to an hexadecimal 'String' +-- +-- user beware, no checks are made +showHexadecimal :: (forall a . (Ptr Word8 -> IO a) -> IO a) -- ^ a 'with' type of function to hold reference to the object + -> Int -- ^ length in bytes + -> String +showHexadecimal withPtr = doChunks 0 + where + doChunks ofs len + | len < 4 = doUnique ofs len + | otherwise = do + let !(a, b, c, d) = unsafeDoIO $ withPtr (read4 ofs) + !(# w1, w2 #) = convertByte a + !(# w3, w4 #) = convertByte b + !(# w5, w6 #) = convertByte c + !(# w7, w8 #) = convertByte d + in wToChar w1 : wToChar w2 : wToChar w3 : wToChar w4 + : wToChar w5 : wToChar w6 : wToChar w7 : wToChar w8 + : doChunks (ofs + 4) (len - 4) + + doUnique ofs len + | len == 0 = [] + | otherwise = + let !b = unsafeDoIO $ withPtr (byteIndex ofs) + !(# w1, w2 #) = convertByte b + in wToChar w1 : wToChar w2 : doUnique (ofs + 1) (len - 1) + + read4 :: Int -> Ptr Word8 -> IO (Word8, Word8, Word8, Word8) + read4 ofs p = + liftM4 (,,,) (byteIndex ofs p) (byteIndex (ofs+1) p) + (byteIndex (ofs+2) p) (byteIndex (ofs+3) p) + + wToChar :: Word8 -> Char + wToChar w = chr (integralUpsize w) + + byteIndex :: Int -> Ptr Word8 -> IO Word8 + byteIndex i p = peekByteOff p i + +-- | Transform a number of bytes pointed by.@src in the hexadecimal binary representation in @dst +-- +-- destination memory need to be of correct size, otherwise it will lead +-- to really bad things. +toHexadecimal :: Ptr Word8 -- ^ destination memory + -> Ptr Word8 -- ^ source memory + -> Int -- ^ number of bytes + -> IO () +toHexadecimal bout bin n = loop 0 + where loop i + | i == n = return () + | otherwise = do + !w <- peekByteOff bin i + let !(# !w1, !w2 #) = convertByte w + pokeByteOff bout (i * 2) w1 + pokeByteOff bout (i * 2 + 1) w2 + loop (i+1) + +-- | Convert a value Word# to two Word#s containing +-- the hexadecimal representation of the Word# +convertByte :: Word8 -> (# Word8, Word8 #) +convertByte bwrap = (# r tableHi b, r tableLo b #) + where + !(W# b) = integralUpsize bwrap + r :: Addr# -> Word# -> Word8 + r table index = W8# (indexWord8OffAddr# table (word2Int# index)) + + !tableLo = + "0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef"# + !tableHi = + "00000000000000001111111111111111\ + \22222222222222223333333333333333\ + \44444444444444445555555555555555\ + \66666666666666667777777777777777\ + \88888888888888889999999999999999\ + \aaaaaaaaaaaaaaaabbbbbbbbbbbbbbbb\ + \ccccccccccccccccdddddddddddddddd\ + \eeeeeeeeeeeeeeeeffffffffffffffff"# +{-# INLINE convertByte #-} + +-- | convert a base16 @src in @dst. +-- +-- n need to even +fromHexadecimal :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int) +fromHexadecimal dst src n + | odd n = error "fromHexadecimal: invalid odd length." + | otherwise = loop 0 0 + where loop di i + | i == n = return Nothing + | otherwise = do + a <- rHi `fmap` peekByteOff src i + b <- rLo `fmap` peekByteOff src (i+1) + if a == 0xff || b == 0xff + then return $ Just i + else pokeByteOff dst di (a .|. b) >> loop (di+1) (i+2) + + rLo, rHi :: Word8 -> Word8 + rLo index = W8# (indexWord8OffAddr# tableLo (word2Int# widx)) + where !(W# widx) = integralUpsize index + rHi index = W8# (indexWord8OffAddr# tableHi (word2Int# widx)) + where !(W# widx) = integralUpsize index + + !tableLo = + "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\xff\xff\xff\xff\xff\xff\ + \\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + !tableHi = + "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\x00\x10\x20\x30\x40\x50\x60\x70\x80\x90\xff\xff\xff\xff\xff\xff\ + \\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# diff --git a/bundled/Data/Memory/Encoding/Base32.hs b/bundled/Data/Memory/Encoding/Base32.hs new file mode 100644 index 0000000..f6344bc --- /dev/null +++ b/bundled/Data/Memory/Encoding/Base32.hs @@ -0,0 +1,256 @@ +-- | +-- Module : Data.Memory.Encoding.Base32 +-- License : BSD-style +-- Maintainer : Nicolas DI PRIMA +-- Stability : experimental +-- Portability : unknown +-- +-- Low-level Base32 encoding and decoding. +-- +-- If you just want to encode or decode some bytes, you probably want to use +-- the "Data.ByteArray.Encoding" module. +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Rank2Types #-} +module Data.Memory.Encoding.Base32 + ( toBase32 + , unBase32Length + , fromBase32 + ) where + +import Data.Memory.Internal.Compat +import Data.Word +import Basement.Bits +import Basement.IntegralConv +import GHC.Prim +import GHC.Word +import Control.Monad +import Foreign.Storable +import Foreign.Ptr (Ptr) + +-- | Transform a number of bytes pointed by.@src in the base32 binary representation in @dst +-- +-- destination memory need to be of correct size, otherwise it will lead +-- to really bad things. +toBase32 :: Ptr Word8 -- ^ input + -> Ptr Word8 -- ^ output + -> Int -- ^ input len + -> IO () +toBase32 dst src len = loop 0 0 + where + eqChar :: Word8 + eqChar = 0x3d + + peekOrZero :: Int -> IO Word8 + peekOrZero i + | i >= len = return 0 + | otherwise = peekByteOff src i + + pokeOrPadding :: Int -- for the test + -> Int -- src index + -> Word8 -- the value + -> IO () + pokeOrPadding i di v + | i < len = pokeByteOff dst di v + | otherwise = pokeByteOff dst di eqChar + + loop :: Int -- index input + -> Int -- index output + -> IO () + loop i di + | i >= len = return () + | otherwise = do + i1 <- peekByteOff src i + i2 <- peekOrZero (i + 1) + i3 <- peekOrZero (i + 2) + i4 <- peekOrZero (i + 3) + i5 <- peekOrZero (i + 4) + + let (o1,o2,o3,o4,o5,o6,o7,o8) = toBase32Per5Bytes (i1, i2, i3, i4, i5) + + pokeByteOff dst di o1 + pokeByteOff dst (di + 1) o2 + pokeOrPadding (i + 1) (di + 2) o3 + pokeOrPadding (i + 1) (di + 3) o4 + pokeOrPadding (i + 2) (di + 4) o5 + pokeOrPadding (i + 3) (di + 5) o6 + pokeOrPadding (i + 3) (di + 6) o7 + pokeOrPadding (i + 4) (di + 7) o8 + + loop (i+5) (di+8) + +toBase32Per5Bytes :: (Word8, Word8, Word8, Word8, Word8) + -> (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8) +toBase32Per5Bytes (!i1, !i2, !i3, !i4, !i5) = + (index o1, index o2, index o3, index o4, index o5, index o6, index o7, index o8) + where + -- 1111 1000 >> 3 + !o1 = (i1 .&. 0xF8) .>>. 3 + -- 0000 0111 << 2 | 1100 0000 >> 6 + !o2 = ((i1 .&. 0x07) .<<. 2) .|. ((i2 .&. 0xC0) .>>. 6) + -- 0011 1110 >> 1 + !o3 = ((i2 .&. 0x3E) .>>. 1) + -- 0000 0001 << 4 | 1111 0000 >> 4 + !o4 = ((i2 .&. 0x01) .<<. 4) .|. ((i3 .&. 0xF0) .>>. 4) + -- 0000 1111 << 1 | 1000 0000 >> 7 + !o5 = ( (i3 .&. 0x0F) .<<. 1) .|. ((i4 .&. 0x80) .>>. 7) + -- 0111 1100 >> 2 + !o6 = (i4 .&. 0x7C) .>>. 2 + -- 0000 0011 << 3 | 1110 0000 >> 5 + !o7 = ((i4 .&. 0x03) .<<. 3) .|. ((i5 .&. 0xE0) .>>. 5) + -- 0001 1111 + !o8 = i5 .&. 0x1F + + !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# + + index :: Word8 -> Word8 + index idx = W8# (indexWord8OffAddr# set (word2Int# widx)) + where !(W# widx) = integralUpsize idx + +-- | Get the length needed for the destination buffer for a base32 decoding. +-- +-- if the length is not a multiple of 8, Nothing is returned +unBase32Length :: Ptr Word8 -> Int -> IO (Maybe Int) +unBase32Length src len + | len < 1 = return $ Just 0 + | (len `mod` 8) /= 0 = return Nothing + | otherwise = do + last1Byte <- peekByteOff src (len - 1) + last2Byte <- peekByteOff src (len - 2) + last3Byte <- peekByteOff src (len - 3) + last4Byte <- peekByteOff src (len - 4) + last5Byte <- peekByteOff src (len - 5) + last6Byte <- peekByteOff src (len - 6) + + let dstLen = caseByte last1Byte last2Byte last3Byte last4Byte last5Byte last6Byte + return $ Just $ (len `div` 8) * 5 - dstLen + where + caseByte :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Int + caseByte last1 last2 last3 last4 last5 last6 + | last6 == eqAscii = 4 + | last5 == eqAscii = 3 -- error this padding is not expected (error will be detected in fromBase32) + | last4 == eqAscii = 3 + | last3 == eqAscii = 2 + | last2 == eqAscii = 1 -- error this padding is not expected (error will be detected in fromBase32) + | last1 == eqAscii = 1 + | otherwise = 0 + + eqAscii :: Word8 + eqAscii = 0x3D + +-- | convert from base32 in @src to binary in @dst, using the number of bytes specified +-- +-- the user should use unBase32Length to compute the correct length, or check that +-- the length specification is proper. no check is done here. +fromBase32 :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int) +fromBase32 dst src len + | len == 0 = return Nothing + | otherwise = loop 0 0 + where + loop :: Int -- the index dst + -> Int -- the index src + -> IO (Maybe Int) + loop di i + | i == (len - 8) = do + i1 <- peekByteOff src i + i2 <- peekByteOff src (i + 1) + i3 <- peekByteOff src (i + 2) + i4 <- peekByteOff src (i + 3) + i5 <- peekByteOff src (i + 4) + i6 <- peekByteOff src (i + 5) + i7 <- peekByteOff src (i + 6) + i8 <- peekByteOff src (i + 7) + + let (nbBytes, i3', i4', i5', i6', i7', i8') = + case (i3, i4, i5, i6, i7, i8) of + (0x3D, 0x3D, 0x3D, 0x3D, 0x3D, 0x3D) -> (6, 0x41, 0x41, 0x41, 0x41, 0x41, 0x41) + (0x3D, _ , _ , _ , _ , _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid + (_ , 0x3D, 0x3D, 0x3D, 0x3D, 0x3D) -> (5, i3 , 0x41, 0x41, 0x41, 0x41, 0x41) + (_ , 0x3D, _ , _ , _ , _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid + (_ , _ , 0x3D, 0x3D, 0x3D, 0x3D) -> (4, i3 , i4 , 0x41, 0x41, 0x41, 0x41) + (_ , _ , 0x3D, _ , _ , _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid + (_ , _ , _ , 0x3D, 0x3D, 0x3D) -> (3, i3 , i4 , i5 , 0x41, 0x41, 0x41) + (_ , _ , _ , 0x3D, _ , _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid + (_ , _ , _ , _ , 0x3D, 0x3D) -> (2, i3 , i4 , i5 , i6 , 0x41, 0x41) + (_ , _ , _ , _ , 0x3D, _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid + (_ , _ , _ , _ , _ , 0x3D) -> (1, i3 , i4 , i5 , i6 , i7 , 0x41) + (_ , _ , _ , _ , _ , _ ) -> (0 :: Int, i3, i4, i5, i6, i7, i8) + + case fromBase32Per8Bytes (i1, i2, i3', i4', i5', i6', i7', i8') of + Left ofs -> return $ Just (i + ofs) + Right (o1, o2, o3, o4, o5) -> do + pokeByteOff dst di o1 + pokeByteOff dst (di+1) o2 + when (nbBytes < 5) $ pokeByteOff dst (di+2) o3 + when (nbBytes < 4) $ pokeByteOff dst (di+3) o4 + when (nbBytes < 2) $ pokeByteOff dst (di+4) o5 + return Nothing + + | otherwise = do + i1 <- peekByteOff src i + i2 <- peekByteOff src (i + 1) + i3 <- peekByteOff src (i + 2) + i4 <- peekByteOff src (i + 3) + i5 <- peekByteOff src (i + 4) + i6 <- peekByteOff src (i + 5) + i7 <- peekByteOff src (i + 6) + i8 <- peekByteOff src (i + 7) + + case fromBase32Per8Bytes (i1, i2, i3, i4, i5, i6, i7, i8) of + Left ofs -> return $ Just (i + ofs) + Right (o1, o2, o3, o4, o5) -> do + pokeByteOff dst di o1 + pokeByteOff dst (di+1) o2 + pokeByteOff dst (di+2) o3 + pokeByteOff dst (di+3) o4 + pokeByteOff dst (di+4) o5 + loop (di+5) (i+8) + +fromBase32Per8Bytes :: (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8) + -> Either Int (Word8, Word8, Word8, Word8, Word8) +fromBase32Per8Bytes (i1, i2, i3, i4, i5, i6, i7, i8) = + case (rset i1, rset i2, rset i3, rset i4, rset i5, rset i6, rset i7, rset i8) of + (0xFF, _ , _ , _ , _ , _ , _ , _ ) -> Left 0 + (_ , 0xFF, _ , _ , _ , _ , _ , _ ) -> Left 1 + (_ , _ , 0xFF, _ , _ , _ , _ , _ ) -> Left 2 + (_ , _ , _ , 0xFF, _ , _ , _ , _ ) -> Left 3 + (_ , _ , _ , _ , 0xFF, _ , _ , _ ) -> Left 4 + (_ , _ , _ , _ , _ , 0xFF, _ , _ ) -> Left 5 + (_ , _ , _ , _ , _ , _ , 0xFF, _ ) -> Left 6 + (_ , _ , _ , _ , _ , _ , _ , 0xFF) -> Left 7 + (ri1 , ri2 , ri3 , ri4 , ri5 , ri6 , ri7 , ri8 ) -> + -- 0001 1111 << 3 | 0001 11xx >> 2 + let o1 = (ri1 `unsafeShiftL` 3) .|. (ri2 `unsafeShiftR` 2) + -- 000x xx11 << 6 | 0001 1111 << 1 | 0001 xxxx >> 4 + o2 = (ri2 `unsafeShiftL` 6) .|. (ri3 `unsafeShiftL` 1) .|. (ri4 `unsafeShiftR` 4) + -- 000x 1111 << 4 | 0001 111x >> 1 + o3 = (ri4 `unsafeShiftL` 4) .|. (ri5 `unsafeShiftR` 1) + -- 000x xxx1 << 7 | 0001 1111 << 2 | 0001 1xxx >> 3 + o4 = (ri5 `unsafeShiftL` 7) .|. (ri6 `unsafeShiftL` 2) .|. (ri7 `unsafeShiftR` 3) + -- 000x x111 << 5 | 0001 1111 + o5 = (ri7 `unsafeShiftL` 5) .|. ri8 + in Right (o1, o2, o3, o4, o5) + where + rset :: Word8 -> Word8 + rset w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx)) + where !(W# widx) = integralUpsize w + + !rsetTable = "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\x1A\x1B\x1C\x1D\x1E\x1F\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\ + \\x0F\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF"# diff --git a/bundled/Data/Memory/Encoding/Base64.hs b/bundled/Data/Memory/Encoding/Base64.hs new file mode 100644 index 0000000..89dd235 --- /dev/null +++ b/bundled/Data/Memory/Encoding/Base64.hs @@ -0,0 +1,328 @@ +-- | +-- Module : Data.Memory.Encoding.Base64 +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Low-level Base64 encoding and decoding. +-- +-- If you just want to encode or decode some bytes, you probably want to use +-- the "Data.ByteArray.Encoding" module. +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Rank2Types #-} +module Data.Memory.Encoding.Base64 + ( toBase64 + , toBase64URL + , toBase64OpenBSD + , unBase64Length + , unBase64LengthUnpadded + , fromBase64 + , fromBase64URLUnpadded + , fromBase64OpenBSD + ) where + +import Data.Memory.Internal.Compat +import Data.Memory.Internal.Imports +import Basement.Bits +import Basement.IntegralConv (integralUpsize) +import GHC.Prim +import GHC.Word +import Foreign.Storable +import Foreign.Ptr (Ptr) + +-- | Transform a number of bytes pointed by @src@ to base64 binary representation in @dst@ +-- +-- The destination memory need to be of correct size, otherwise it will lead +-- to really bad things. +toBase64 :: Ptr Word8 -> Ptr Word8 -> Int -> IO () +toBase64 dst src len = toBase64Internal set dst src len True + where + !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"# + +-- | Transform a number of bytes pointed by @src@ to, URL-safe base64 binary +-- representation in @dst@. The result will be either padded or unpadded, +-- depending on the boolean @padded@ argument. +-- +-- The destination memory need to be of correct size, otherwise it will lead +-- to really bad things. +toBase64URL :: Bool -> Ptr Word8 -> Ptr Word8 -> Int -> IO () +toBase64URL padded dst src len = toBase64Internal set dst src len padded + where + !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"# + +toBase64OpenBSD :: Ptr Word8 -> Ptr Word8 -> Int -> IO () +toBase64OpenBSD dst src len = toBase64Internal set dst src len False + where + !set = "./ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"# + +toBase64Internal :: Addr# -> Ptr Word8 -> Ptr Word8 -> Int -> Bool -> IO () +toBase64Internal table dst src len padded = loop 0 0 + where + eqChar = 0x3d :: Word8 + + loop i di + | i >= len = return () + | otherwise = do + a <- peekByteOff src i + b <- if i + 1 >= len then return 0 else peekByteOff src (i+1) + c <- if i + 2 >= len then return 0 else peekByteOff src (i+2) + + let (w,x,y,z) = convert3 table a b c + + pokeByteOff dst di w + pokeByteOff dst (di+1) x + + if i + 1 < len + then + pokeByteOff dst (di+2) y + else + when padded (pokeByteOff dst (di+2) eqChar) + if i + 2 < len + then + pokeByteOff dst (di+3) z + else + when padded (pokeByteOff dst (di+3) eqChar) + + loop (i+3) (di+4) + +convert3 :: Addr# -> Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8) +convert3 table !a !b !c = + let !w = a .>>. 2 + !x = ((a .<<. 4) .&. 0x30) .|. (b .>>. 4) + !y = ((b .<<. 2) .&. 0x3c) .|. (c .>>. 6) + !z = c .&. 0x3f + in (index w, index x, index y, index z) + where + index :: Word8 -> Word8 + index !idxb = W8# (indexWord8OffAddr# table (word2Int# idx)) + where !(W# idx) = integralUpsize idxb + +-- | Get the length needed for the destination buffer for a base64 decoding. +-- +-- if the length is not a multiple of 4, Nothing is returned +unBase64Length :: Ptr Word8 -> Int -> IO (Maybe Int) +unBase64Length src len + | len < 1 = return $ Just 0 + | (len `mod` 4) /= 0 = return Nothing + | otherwise = do + last1Byte <- peekByteOff src (len - 1) + last2Byte <- peekByteOff src (len - 2) + let dstLen = if last1Byte == eqAscii + then if last2Byte == eqAscii then 2 else 1 + else 0 + return $ Just $ (len `div` 4) * 3 - dstLen + where + eqAscii :: Word8 + eqAscii = fromIntegral (fromEnum '=') + +-- | Get the length needed for the destination buffer for an +-- base64 decoding. +-- +-- If the length of the encoded string is a multiple of 4, plus one, Nothing is +-- returned. Any other value can be valid without padding. +unBase64LengthUnpadded :: Int -> Maybe Int +unBase64LengthUnpadded len = case r of + 0 -> Just (3*q) + 2 -> Just (3*q + 1) + 3 -> Just (3*q + 2) + _ -> Nothing + where (q, r) = len `divMod` 4 + +fromBase64OpenBSD :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int) +fromBase64OpenBSD dst src len = fromBase64Unpadded rsetOpenBSD dst src len + +fromBase64URLUnpadded :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int) +fromBase64URLUnpadded dst src len = fromBase64Unpadded rsetURL dst src len + +fromBase64Unpadded :: (Word8 -> Word8) -> Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int) +fromBase64Unpadded rset dst src len = loop 0 0 + where loop di i + | i == len = return Nothing + | i == len - 1 = return Nothing -- Shouldn't happen if len is valid + | i == len - 2 = do + a <- peekByteOff src i + b <- peekByteOff src (i+1) + + case decode2 a b of + Left ofs -> return $ Just (i + ofs) + Right x -> do + pokeByteOff dst di x + return Nothing + | i == len - 3 = do + a <- peekByteOff src i + b <- peekByteOff src (i+1) + c <- peekByteOff src (i+2) + + case decode3 a b c of + Left ofs -> return $ Just (i + ofs) + Right (x,y) -> do + pokeByteOff dst di x + pokeByteOff dst (di+1) y + return Nothing + | otherwise = do + a <- peekByteOff src i + b <- peekByteOff src (i+1) + c <- peekByteOff src (i+2) + d <- peekByteOff src (i+3) + + case decode4 a b c d of + Left ofs -> return $ Just (i + ofs) + Right (x,y,z) -> do + pokeByteOff dst di x + pokeByteOff dst (di+1) y + pokeByteOff dst (di+2) z + loop (di + 3) (i + 4) + + decode2 :: Word8 -> Word8 -> Either Int Word8 + decode2 a b = + case (rset a, rset b) of + (0xff, _ ) -> Left 0 + (_ , 0xff) -> Left 1 + (ra , rb ) -> Right ((ra `unsafeShiftL` 2) .|. (rb `unsafeShiftR` 4)) + + decode3 :: Word8 -> Word8 -> Word8 -> Either Int (Word8, Word8) + decode3 a b c = + case (rset a, rset b, rset c) of + (0xff, _ , _ ) -> Left 0 + (_ , 0xff, _ ) -> Left 1 + (_ , _ , 0xff) -> Left 2 + (ra , rb , rc ) -> + let x = (ra `unsafeShiftL` 2) .|. (rb `unsafeShiftR` 4) + y = (rb `unsafeShiftL` 4) .|. (rc `unsafeShiftR` 2) + in Right (x,y) + + + decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Int (Word8, Word8, Word8) + decode4 a b c d = + case (rset a, rset b, rset c, rset d) of + (0xff, _ , _ , _ ) -> Left 0 + (_ , 0xff, _ , _ ) -> Left 1 + (_ , _ , 0xff, _ ) -> Left 2 + (_ , _ , _ , 0xff) -> Left 3 + (ra , rb , rc , rd ) -> + let x = (ra `unsafeShiftL` 2) .|. (rb `unsafeShiftR` 4) + y = (rb `unsafeShiftL` 4) .|. (rc `unsafeShiftR` 2) + z = (rc `unsafeShiftL` 6) .|. rd + in Right (x,y,z) + +rsetURL :: Word8 -> Word8 +rsetURL !w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx)) + where !(W# widx) = integralUpsize w + !rsetTable = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\xff\xff\ + \\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\xff\xff\xff\xff\xff\xff\ + \\xff\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\ + \\x0f\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\xff\xff\xff\xff\x3f\ + \\xff\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\ + \\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +rsetOpenBSD :: Word8 -> Word8 +rsetOpenBSD !w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx)) + where !(W# widx) = integralUpsize w + !rsetTable = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\ + \\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\xff\xff\xff\xff\xff\xff\ + \\xff\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10\ + \\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\xff\xff\xff\xff\xff\ + \\xff\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\ + \\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + + +-- | convert from base64 in @src@ to binary in @dst@, using the number of bytes specified +-- +-- the user should use unBase64Length to compute the correct length, or check that +-- the length specification is proper. no check is done here. +fromBase64 :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int) +fromBase64 dst src len + | len == 0 = return Nothing + | otherwise = loop 0 0 + where loop di i + | i == (len-4) = do + a <- peekByteOff src i + b <- peekByteOff src (i+1) + c <- peekByteOff src (i+2) + d <- peekByteOff src (i+3) + + let (nbBytes, c',d') = + case (c,d) of + (0x3d, 0x3d) -> (2, 0x30, 0x30) + (0x3d, _ ) -> (0, c, d) -- invalid: automatically 'c' will make it error out + (_ , 0x3d) -> (1, c, 0x30) + (_ , _ ) -> (0 :: Int, c, d) + case decode4 a b c' d' of + Left ofs -> return $ Just (i + ofs) + Right (x,y,z) -> do + pokeByteOff dst di x + when (nbBytes < 2) $ pokeByteOff dst (di+1) y + when (nbBytes < 1) $ pokeByteOff dst (di+2) z + return Nothing + | otherwise = do + a <- peekByteOff src i + b <- peekByteOff src (i+1) + c <- peekByteOff src (i+2) + d <- peekByteOff src (i+3) + + case decode4 a b c d of + Left ofs -> return $ Just (i + ofs) + Right (x,y,z) -> do + pokeByteOff dst di x + pokeByteOff dst (di+1) y + pokeByteOff dst (di+2) z + loop (di + 3) (i + 4) + + decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Int (Word8, Word8, Word8) + decode4 a b c d = + case (rset a, rset b, rset c, rset d) of + (0xff, _ , _ , _ ) -> Left 0 + (_ , 0xff, _ , _ ) -> Left 1 + (_ , _ , 0xff, _ ) -> Left 2 + (_ , _ , _ , 0xff) -> Left 3 + (ra , rb , rc , rd ) -> + let x = (ra `unsafeShiftL` 2) .|. (rb `unsafeShiftR` 4) + y = (rb `unsafeShiftL` 4) .|. (rc `unsafeShiftR` 2) + z = (rc `unsafeShiftL` 6) .|. rd + in Right (x,y,z) + + rset :: Word8 -> Word8 + rset !w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx)) + where !(W# widx) = integralUpsize w + + !rsetTable = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\xff\xff\xff\x3f\ + \\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\xff\xff\xff\xff\xff\xff\ + \\xff\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\ + \\x0f\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\xff\xff\xff\xff\xff\ + \\xff\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\ + \\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# diff --git a/bundled/Data/Memory/Endian.hs b/bundled/Data/Memory/Endian.hs new file mode 100644 index 0000000..67c4223 --- /dev/null +++ b/bundled/Data/Memory/Endian.hs @@ -0,0 +1,121 @@ +-- | +-- Module : Data.Memory.Endian +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : good +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Data.Memory.Endian + ( Endianness(..) + , getSystemEndianness + , BE(..), LE(..) + , fromBE, toBE + , fromLE, toLE + , ByteSwap + ) where + +import Data.Word (Word16, Word32, Word64) +import Foreign.Storable +#if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN) +import Data.Word (Word8) +import Data.Memory.Internal.Compat (unsafeDoIO) +import Foreign.Marshal.Alloc +import Foreign.Ptr +#endif + +import Data.Memory.Internal.Compat (byteSwap64, byteSwap32, byteSwap16) + +-- | represent the CPU endianness +-- +-- Big endian system stores bytes with the MSB as the first byte. +-- Little endian system stores bytes with the LSB as the first byte. +-- +-- middle endian is purposely avoided. +data Endianness = LittleEndian + | BigEndian + deriving (Show,Eq) + +-- | Return the system endianness +getSystemEndianness :: Endianness +#ifdef ARCH_IS_LITTLE_ENDIAN +getSystemEndianness = LittleEndian +#elif ARCH_IS_BIG_ENDIAN +getSystemEndianness = BigEndian +#else +getSystemEndianness + | isLittleEndian = LittleEndian + | isBigEndian = BigEndian + | otherwise = error "cannot determine endianness" + where + isLittleEndian = endianCheck == 2 + isBigEndian = endianCheck == 1 + endianCheck = unsafeDoIO $ alloca $ \p -> do + poke p (0x01000002 :: Word32) + peek (castPtr p :: Ptr Word8) +#endif + +-- | Little Endian value +newtype LE a = LE { unLE :: a } + deriving (Show,Eq,Storable) + +-- | Big Endian value +newtype BE a = BE { unBE :: a } + deriving (Show,Eq,Storable) + +-- | Convert a value in cpu endianess to big endian +toBE :: ByteSwap a => a -> BE a +#ifdef ARCH_IS_LITTLE_ENDIAN +toBE = BE . byteSwap +#elif ARCH_IS_BIG_ENDIAN +toBE = BE +#else +toBE = BE . (if getSystemEndianness == LittleEndian then byteSwap else id) +#endif +{-# INLINE toBE #-} + +-- | Convert from a big endian value to the cpu endianness +fromBE :: ByteSwap a => BE a -> a +#ifdef ARCH_IS_LITTLE_ENDIAN +fromBE (BE a) = byteSwap a +#elif ARCH_IS_BIG_ENDIAN +fromBE (BE a) = a +#else +fromBE (BE a) = if getSystemEndianness == LittleEndian then byteSwap a else a +#endif +{-# INLINE fromBE #-} + +-- | Convert a value in cpu endianess to little endian +toLE :: ByteSwap a => a -> LE a +#ifdef ARCH_IS_LITTLE_ENDIAN +toLE = LE +#elif ARCH_IS_BIG_ENDIAN +toLE = LE . byteSwap +#else +toLE = LE . (if getSystemEndianness == LittleEndian then id else byteSwap) +#endif +{-# INLINE toLE #-} + +-- | Convert from a little endian value to the cpu endianness +fromLE :: ByteSwap a => LE a -> a +#ifdef ARCH_IS_LITTLE_ENDIAN +fromLE (LE a) = a +#elif ARCH_IS_BIG_ENDIAN +fromLE (LE a) = byteSwap a +#else +fromLE (LE a) = if getSystemEndianness == LittleEndian then a else byteSwap a +#endif +{-# INLINE fromLE #-} + +-- | Class of types that can be byte-swapped. +-- +-- e.g. Word16, Word32, Word64 +class Storable a => ByteSwap a where + byteSwap :: a -> a +instance ByteSwap Word16 where + byteSwap = byteSwap16 +instance ByteSwap Word32 where + byteSwap = byteSwap32 +instance ByteSwap Word64 where + byteSwap = byteSwap64 diff --git a/bundled/Data/Memory/ExtendedWords.hs b/bundled/Data/Memory/ExtendedWords.hs new file mode 100644 index 0000000..1bc2307 --- /dev/null +++ b/bundled/Data/Memory/ExtendedWords.hs @@ -0,0 +1,17 @@ +-- | +-- Module : Data.Memory.ExtendedWords +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Extra Word size +-- +module Data.Memory.ExtendedWords + ( Word128(..) + ) where + +import Data.Word (Word64) + +-- | A simple Extended Word128 composed of 2 Word64 +data Word128 = Word128 !Word64 !Word64 deriving (Show, Eq) diff --git a/bundled/Data/Memory/Hash/FNV.hs b/bundled/Data/Memory/Hash/FNV.hs new file mode 100644 index 0000000..ac39a74 --- /dev/null +++ b/bundled/Data/Memory/Hash/FNV.hs @@ -0,0 +1,106 @@ +-- | +-- Module : Data.Memory.Hash.FNV +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : good +-- +-- Fowler Noll Vo Hash (1 and 1a / 32 / 64 bits versions) +-- +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +module Data.Memory.Hash.FNV + ( + -- * types + FnvHash32(..) + , FnvHash64(..) + -- * methods + , fnv1 + , fnv1a + , fnv1_64 + , fnv1a_64 + ) where + +import Basement.Bits +import Basement.IntegralConv +import Data.Memory.Internal.Compat () +import Data.Memory.Internal.Imports +import GHC.Word +import GHC.Prim hiding (Word64#, Int64#) +import GHC.Types +import GHC.Ptr + +-- | FNV1(a) hash (32 bit variants) +newtype FnvHash32 = FnvHash32 Word32 + deriving (Show,Eq,Ord,NFData) + +-- | FNV1(a) hash (64 bit variants) +newtype FnvHash64 = FnvHash64 Word64 + deriving (Show,Eq,Ord,NFData) + +fnv1_32_Mix8 :: Word8 -> FnvHash32 -> FnvHash32 +fnv1_32_Mix8 !w (FnvHash32 acc) = FnvHash32 ((0x01000193 * acc) .^. integralUpsize w) +{-# INLINE fnv1_32_Mix8 #-} + +fnv1a_32_Mix8 :: Word8 -> FnvHash32 -> FnvHash32 +fnv1a_32_Mix8 !w (FnvHash32 acc) = FnvHash32 (0x01000193 * (acc .^. integralUpsize w)) +{-# INLINE fnv1a_32_Mix8 #-} + +fnv1_64_Mix8 :: Word8 -> FnvHash64 -> FnvHash64 +fnv1_64_Mix8 !w (FnvHash64 acc) = FnvHash64 ((0x100000001b3 * acc) .^. integralUpsize w) +{-# INLINE fnv1_64_Mix8 #-} + +fnv1a_64_Mix8 :: Word8 -> FnvHash64 -> FnvHash64 +fnv1a_64_Mix8 !w (FnvHash64 acc) = FnvHash64 (0x100000001b3 * (acc .^. integralUpsize w)) +{-# INLINE fnv1a_64_Mix8 #-} + +-- | compute FNV1 (32 bit variant) of a raw piece of memory +fnv1 :: Ptr Word8 -> Int -> IO FnvHash32 +fnv1 (Ptr addr) n = loop (FnvHash32 0x811c9dc5) 0 + where + loop :: FnvHash32 -> Int -> IO FnvHash32 + loop !acc !i + | i == n = pure $ acc + | otherwise = do + v <- read8 addr i + loop (fnv1_32_Mix8 v acc) (i + 1) + +-- | compute FNV1a (32 bit variant) of a raw piece of memory +fnv1a :: Ptr Word8 -> Int -> IO FnvHash32 +fnv1a (Ptr addr) n = loop (FnvHash32 0x811c9dc5) 0 + where + loop :: FnvHash32 -> Int -> IO FnvHash32 + loop !acc !i + | i == n = pure $ acc + | otherwise = do + v <- read8 addr i + loop (fnv1a_32_Mix8 v acc) (i + 1) + +-- | compute FNV1 (64 bit variant) of a raw piece of memory +fnv1_64 :: Ptr Word8 -> Int -> IO FnvHash64 +fnv1_64 (Ptr addr) n = loop (FnvHash64 0xcbf29ce484222325) 0 + where + loop :: FnvHash64 -> Int -> IO FnvHash64 + loop !acc !i + | i == n = pure $ acc + | otherwise = do + v <- read8 addr i + loop (fnv1_64_Mix8 v acc) (i + 1) + +-- | compute FNV1a (64 bit variant) of a raw piece of memory +fnv1a_64 :: Ptr Word8 -> Int -> IO FnvHash64 +fnv1a_64 (Ptr addr) n = loop (FnvHash64 0xcbf29ce484222325) 0 + where + loop :: FnvHash64 -> Int -> IO FnvHash64 + loop !acc !i + | i == n = pure $ acc + | otherwise = do + v <- read8 addr i + loop (fnv1a_64_Mix8 v acc) (i + 1) + +read8 :: Addr# -> Int -> IO Word8 +read8 addr (I# i) = IO $ \s -> case readWord8OffAddr# addr i s of + (# s2, e #) -> (# s2, W8# e #) diff --git a/bundled/Data/Memory/Hash/SipHash.hs b/bundled/Data/Memory/Hash/SipHash.hs new file mode 100644 index 0000000..a25ed8e --- /dev/null +++ b/bundled/Data/Memory/Hash/SipHash.hs @@ -0,0 +1,163 @@ +-- | +-- Module : Data.Memory.Hash.SipHash +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : good +-- +-- provide the SipHash algorithm. +-- reference: +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Data.Memory.Hash.SipHash + ( SipKey(..) + , SipHash(..) + , hash + , hashWith + ) where + +import Data.Memory.Endian +import Data.Memory.Internal.Compat +import Data.Word +import Data.Bits +import Data.Typeable (Typeable) +import Control.Monad +import Foreign.Ptr +import Foreign.Storable + +-- | SigHash Key +data SipKey = SipKey {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 + +-- | Siphash tag value +newtype SipHash = SipHash Word64 + deriving (Show,Eq,Ord,Typeable) + +data InternalState = InternalState {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 + +-- | produce a siphash with a key and a memory pointer + length. +hash :: SipKey -> Ptr Word8 -> Int -> IO SipHash +hash = hashWith 2 4 + +-- | same as 'hash', except also specifies the number of sipround iterations for compression and digest. +hashWith :: Int -- ^ siphash C + -> Int -- ^ siphash D + -> SipKey -- ^ key for the hash + -> Ptr Word8 -- ^ memory pointer + -> Int -- ^ length of the data + -> IO SipHash +hashWith c d key startPtr totalLen = runHash (initSip key) startPtr totalLen + where runHash !st !ptr l + | l > 7 = peek (castPtr ptr) >>= \v -> runHash (process st (fromLE v)) (ptr `plusPtr` 8) (l-8) + | otherwise = do + let !lengthBlock = (fromIntegral totalLen `mod` 256) `unsafeShiftL` 56 + (finish . process st) `fmap` case l of + 0 -> do return lengthBlock + 1 -> do v0 <- peekByteOff ptr 0 + return (lengthBlock .|. to64 v0) + 2 -> do (v0,v1) <- liftM2 (,) (peekByteOff ptr 0) (peekByteOff ptr 1) + return (lengthBlock + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + 3 -> do (v0,v1,v2) <- liftM3 (,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2) + return ( lengthBlock + .|. (to64 v2 `unsafeShiftL` 16) + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + 4 -> do (v0,v1,v2,v3) <- liftM4 (,,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2) + (peekByteOff ptr 3) + return ( lengthBlock + .|. (to64 v3 `unsafeShiftL` 24) + .|. (to64 v2 `unsafeShiftL` 16) + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + 5 -> do (v0,v1,v2,v3,v4) <- liftM5 (,,,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2) + (peekByteOff ptr 3) (peekByteOff ptr 4) + return ( lengthBlock + .|. (to64 v4 `unsafeShiftL` 32) + .|. (to64 v3 `unsafeShiftL` 24) + .|. (to64 v2 `unsafeShiftL` 16) + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + 6 -> do v0 <- peekByteOff ptr 0 + v1 <- peekByteOff ptr 1 + v2 <- peekByteOff ptr 2 + v3 <- peekByteOff ptr 3 + v4 <- peekByteOff ptr 4 + v5 <- peekByteOff ptr 5 + return ( lengthBlock + .|. (to64 v5 `unsafeShiftL` 40) + .|. (to64 v4 `unsafeShiftL` 32) + .|. (to64 v3 `unsafeShiftL` 24) + .|. (to64 v2 `unsafeShiftL` 16) + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + 7 -> do v0 <- peekByteOff ptr 0 + v1 <- peekByteOff ptr 1 + v2 <- peekByteOff ptr 2 + v3 <- peekByteOff ptr 3 + v4 <- peekByteOff ptr 4 + v5 <- peekByteOff ptr 5 + v6 <- peekByteOff ptr 6 + return ( lengthBlock + .|. (to64 v6 `unsafeShiftL` 48) + .|. (to64 v5 `unsafeShiftL` 40) + .|. (to64 v4 `unsafeShiftL` 32) + .|. (to64 v3 `unsafeShiftL` 24) + .|. (to64 v2 `unsafeShiftL` 16) + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + _ -> error "siphash: internal error: cannot happens" + + {-# INLINE to64 #-} + to64 :: Word8 -> Word64 + to64 = fromIntegral + + {-# INLINE process #-} + process istate m = newState + where newState = postInject $! runRoundsCompression $! preInject istate + preInject (InternalState v0 v1 v2 v3) = InternalState v0 v1 v2 (v3 `xor` m) + postInject (InternalState v0 v1 v2 v3) = InternalState (v0 `xor` m) v1 v2 v3 + + {-# INLINE finish #-} + finish istate = getDigest $! runRoundsDigest $! preInject istate + where getDigest (InternalState v0 v1 v2 v3) = SipHash (v0 `xor` v1 `xor` v2 `xor` v3) + preInject (InternalState v0 v1 v2 v3) = InternalState v0 v1 (v2 `xor` 0xff) v3 + + {-# INLINE doRound #-} + doRound (InternalState v0 v1 v2 v3) = + let !v0' = v0 + v1 + !v2' = v2 + v3 + !v1' = v1 `rotateL` 13 + !v3' = v3 `rotateL` 16 + !v1'' = v1' `xor` v0' + !v3'' = v3' `xor` v2' + !v0'' = v0' `rotateL` 32 + !v2'' = v2' + v1'' + !v0''' = v0'' + v3'' + !v1''' = v1'' `rotateL` 17 + !v3''' = v3'' `rotateL` 21 + !v1'''' = v1''' `xor` v2'' + !v3'''' = v3''' `xor` v0''' + !v2''' = v2'' `rotateL` 32 + in InternalState v0''' v1'''' v2''' v3'''' + + {-# INLINE runRoundsCompression #-} + runRoundsCompression st + | c == 2 = doRound $! doRound st + | otherwise = loopRounds c st + + {-# INLINE runRoundsDigest #-} + runRoundsDigest st + | d == 4 = doRound $! doRound $! doRound $! doRound st + | otherwise = loopRounds d st + + {-# INLINE loopRounds #-} + loopRounds 1 !v = doRound v + loopRounds n !v = loopRounds (n-1) (doRound v) + + {-# INLINE initSip #-} + initSip (SipKey k0 k1) = InternalState (k0 `xor` 0x736f6d6570736575) + (k1 `xor` 0x646f72616e646f6d) + (k0 `xor` 0x6c7967656e657261) + (k1 `xor` 0x7465646279746573) diff --git a/bundled/Data/Memory/Internal/Compat.hs b/bundled/Data/Memory/Internal/Compat.hs new file mode 100644 index 0000000..229ef2d --- /dev/null +++ b/bundled/Data/Memory/Internal/Compat.hs @@ -0,0 +1,76 @@ +-- | +-- Module : Data.Memory.Internal.Compat +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +-- This module try to keep all the difference between versions of base +-- or other needed packages, so that modules don't need to use CPP +-- +{-# LANGUAGE CPP #-} +module Data.Memory.Internal.Compat + ( unsafeDoIO + , popCount + , unsafeShiftL + , unsafeShiftR + , byteSwap64 + , byteSwap32 + , byteSwap16 + ) where + +import System.IO.Unsafe +import Data.Word +import Data.Bits + +-- | perform io for hashes that do allocation and ffi. +-- unsafeDupablePerformIO is used when possible as the +-- computation is pure and the output is directly linked +-- to the input. we also do not modify anything after it has +-- been returned to the user. +unsafeDoIO :: IO a -> a +#if __GLASGOW_HASKELL__ > 704 +unsafeDoIO = unsafeDupablePerformIO +#else +unsafeDoIO = unsafePerformIO +#endif + +#if !(MIN_VERSION_base(4,5,0)) +popCount :: Word64 -> Int +popCount n = loop 0 n + where loop c 0 = c + loop c i = loop (c + if testBit c 0 then 1 else 0) (i `shiftR` 1) +#endif + +#if !(MIN_VERSION_base(4,7,0)) +byteSwap64 :: Word64 -> Word64 +byteSwap64 w = + (w `shiftR` 56) .|. (w `shiftL` 56) + .|. ((w `shiftR` 40) .&. 0xff00) .|. ((w .&. 0xff00) `shiftL` 40) + .|. ((w `shiftR` 24) .&. 0xff0000) .|. ((w .&. 0xff0000) `shiftL` 24) + .|. ((w `shiftR` 8) .&. 0xff000000) .|. ((w .&. 0xff000000) `shiftL` 8) +#endif + +#if !(MIN_VERSION_base(4,7,0)) +byteSwap32 :: Word32 -> Word32 +byteSwap32 w = + (w `shiftR` 24) + .|. (w `shiftL` 24) + .|. ((w `shiftR` 8) .&. 0xff00) + .|. ((w .&. 0xff00) `shiftL` 8) +#endif + +#if !(MIN_VERSION_base(4,7,0)) +byteSwap16 :: Word16 -> Word16 +byteSwap16 w = + (w `shiftR` 8) .|. (w `shiftL` 8) +#endif + +#if !(MIN_VERSION_base(4,5,0)) +unsafeShiftL :: Bits a => a -> Int -> a +unsafeShiftL = shiftL + +unsafeShiftR :: Bits a => a -> Int -> a +unsafeShiftR = shiftR +#endif + diff --git a/bundled/Data/Memory/Internal/CompatPrim.hs b/bundled/Data/Memory/Internal/CompatPrim.hs new file mode 100644 index 0000000..e4ab5cd --- /dev/null +++ b/bundled/Data/Memory/Internal/CompatPrim.hs @@ -0,0 +1,70 @@ +-- | +-- Module : Data.Memory.Internal.CompatPrim +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Compat +-- +-- This module try to keep all the difference between versions of ghc primitive +-- or other needed packages, so that modules don't need to use CPP. +-- +-- Note that MagicHash and CPP conflicts in places, making it "more interesting" +-- to write compat code for primitives +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +module Data.Memory.Internal.CompatPrim + ( be32Prim + , le32Prim + , byteswap32Prim + , booleanPrim + ) where + +import GHC.Prim + +-- | byteswap Word# to or from Big Endian +-- +-- on a big endian machine, this function is a nop. +be32Prim :: Word# -> Word# +#ifdef ARCH_IS_LITTLE_ENDIAN +be32Prim = byteswap32Prim +#else +be32Prim w = w +#endif + +-- | byteswap Word# to or from Little Endian +-- +-- on a little endian machine, this function is a nop. +le32Prim :: Word# -> Word# +#ifdef ARCH_IS_LITTLE_ENDIAN +le32Prim w = w +#else +le32Prim = byteswap32Prim +#endif + +-- | Simple compatibility for byteswap the lower 32 bits of a Word# +-- at the primitive level +byteswap32Prim :: Word# -> Word# +#if __GLASGOW_HASKELL__ >= 708 +byteswap32Prim w = byteSwap32# w +#else +byteswap32Prim w = + let !a = uncheckedShiftL# w 24# + !b = and# (uncheckedShiftL# w 8#) 0x00ff0000## + !c = and# (uncheckedShiftRL# w 8#) 0x0000ff00## + !d = and# (uncheckedShiftRL# w 24#) 0x000000ff## + in or# a (or# b (or# c d)) +#endif + +-- | Simple wrapper to handle pre 7.8 and future, where +-- most comparaison functions don't returns a boolean +-- anymore. +#if __GLASGOW_HASKELL__ >= 708 +booleanPrim :: Int# -> Bool +booleanPrim v = tagToEnum# v +#else +booleanPrim :: Bool -> Bool +booleanPrim b = b +#endif +{-# INLINE booleanPrim #-} diff --git a/bundled/Data/Memory/Internal/CompatPrim64.hs b/bundled/Data/Memory/Internal/CompatPrim64.hs new file mode 100644 index 0000000..b9eef8a --- /dev/null +++ b/bundled/Data/Memory/Internal/CompatPrim64.hs @@ -0,0 +1,169 @@ +-- | +-- Module : Data.Memory.Internal.CompatPrim +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Compat +-- +-- This module try to keep all the difference between versions of ghc primitive +-- or other needed packages, so that modules don't need to use CPP. +-- +-- Note that MagicHash and CPP conflicts in places, making it "more interesting" +-- to write compat code for primitives +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +#include "MachDeps.h" +module Data.Memory.Internal.CompatPrim64 + ( Word64# + , Int64# + , eqInt64# + , neInt64# + , ltInt64# + , leInt64# + , gtInt64# + , geInt64# + , quotInt64# + , remInt64# + , eqWord64# + , neWord64# + , ltWord64# + , leWord64# + , gtWord64# + , geWord64# + , and64# + , or64# + , xor64# + , not64# + , timesWord64# + , uncheckedShiftL64# + , uncheckedShiftRL64# + + , int64ToWord64# + , word64ToInt64# + , intToInt64# + , int64ToInt# + , wordToWord64# + , word64ToWord# + , w64# + ) where + + +#if WORD_SIZE_IN_BITS == 64 +import GHC.Prim hiding (Word64#, Int64#) + +#if __GLASGOW_HASKELL__ >= 708 +type OutBool = Int# +#else +type OutBool = Bool +#endif + +type Word64# = Word# +type Int64# = Int# + +#if __GLASGOW_HASKELL__ < 904 +eqWord64# :: Word64# -> Word64# -> OutBool +eqWord64# = eqWord# + +neWord64# :: Word64# -> Word64# -> OutBool +neWord64# = neWord# + +ltWord64# :: Word64# -> Word64# -> OutBool +ltWord64# = ltWord# + +leWord64# :: Word64# -> Word64# -> OutBool +leWord64# = leWord# + +gtWord64# :: Word64# -> Word64# -> OutBool +gtWord64# = gtWord# + +geWord64# :: Word64# -> Word64# -> OutBool +geWord64# = geWord# + +eqInt64# :: Int64# -> Int64# -> OutBool +eqInt64# = (==#) + +neInt64# :: Int64# -> Int64# -> OutBool +neInt64# = (/=#) + +ltInt64# :: Int64# -> Int64# -> OutBool +ltInt64# = (<#) + +leInt64# :: Int64# -> Int64# -> OutBool +leInt64# = (<=#) + +gtInt64# :: Int64# -> Int64# -> OutBool +gtInt64# = (>#) + +geInt64# :: Int64# -> Int64# -> OutBool +geInt64# = (<=#) + +quotInt64# :: Int64# -> Int64# -> Int64# +quotInt64# = quotInt# + +remInt64# :: Int64# -> Int64# -> Int64# +remInt64# = remInt# + +and64# :: Word64# -> Word64# -> Word64# +and64# = and# + +or64# :: Word64# -> Word64# -> Word64# +or64# = or# + +xor64# :: Word64# -> Word64# -> Word64# +xor64# = xor# + +not64# :: Word64# -> Word64# +not64# = not# + +uncheckedShiftL64# :: Word64# -> Int# -> Word64# +uncheckedShiftL64# = uncheckedShiftL# + +uncheckedShiftRL64# :: Word64# -> Int# -> Word64# +uncheckedShiftRL64# = uncheckedShiftL# + +int64ToWord64# :: Int64# -> Word64# +int64ToWord64# = int2Word# + +word64ToInt64# :: Word64# -> Int64# +word64ToInt64# = word2Int# + +intToInt64# :: Int# -> Int64# +intToInt64# w = w + +int64ToInt# :: Int64# -> Int# +int64ToInt# w = w + +wordToWord64# :: Word# -> Word64# +wordToWord64# w = w + +word64ToWord# :: Word64# -> Word# +word64ToWord# w = w + +timesWord64# :: Word64# -> Word64# -> Word64# +timesWord64# = timesWord# +#endif + +w64# :: Word# -> Word# -> Word# -> Word64# +w64# w _ _ = w + +#elif WORD_SIZE_IN_BITS == 32 +import GHC.IntWord64 +import GHC.Prim (Word#) + +timesWord64# :: Word64# -> Word64# -> Word64# +timesWord64# a b = + let !ai = word64ToInt64# a + !bi = word64ToInt64# b + in int64ToWord64# (timesInt64# ai bi) + +w64# :: Word# -> Word# -> Word# -> Word64# +w64# _ hw lw = + let !h = wordToWord64# hw + !l = wordToWord64# lw + in or64# (uncheckedShiftL64# h 32#) l +#else +#error "not a supported architecture. supported WORD_SIZE_IN_BITS is 32 bits or 64 bits" +#endif diff --git a/bundled/Data/Memory/Internal/DeepSeq.hs b/bundled/Data/Memory/Internal/DeepSeq.hs new file mode 100644 index 0000000..0ff876f --- /dev/null +++ b/bundled/Data/Memory/Internal/DeepSeq.hs @@ -0,0 +1,28 @@ +-- | +-- Module : Data.Memory.Internal.DeepSeq +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Simple abstraction module to allow compilation without deepseq +-- by defining our own NFData class if not compiling with deepseq +-- support. +-- +{-# LANGUAGE CPP #-} +module Data.Memory.Internal.DeepSeq + ( NFData(..) + ) where + +#ifdef WITH_DEEPSEQ_SUPPORT +import Control.DeepSeq +#else +import Data.Word + +class NFData a where rnf :: a -> () + +instance NFData Word8 where rnf w = w `seq` () +instance NFData Word16 where rnf w = w `seq` () +instance NFData Word32 where rnf w = w `seq` () +instance NFData Word64 where rnf w = w `seq` () +#endif diff --git a/bundled/Data/Memory/Internal/Imports.hs b/bundled/Data/Memory/Internal/Imports.hs new file mode 100644 index 0000000..02949cd --- /dev/null +++ b/bundled/Data/Memory/Internal/Imports.hs @@ -0,0 +1,17 @@ +-- | +-- Module : Data.Memory.Internal.Imports +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +{-# LANGUAGE CPP #-} +module Data.Memory.Internal.Imports + ( module X + ) where + +import Data.Word as X +import Control.Applicative as X +import Control.Monad as X (forM, forM_, void, when) +import Control.Arrow as X (first, second) +import Data.Memory.Internal.DeepSeq as X diff --git a/bundled/Data/Memory/MemMap/Posix.hsc b/bundled/Data/Memory/MemMap/Posix.hsc new file mode 100644 index 0000000..16bc246 --- /dev/null +++ b/bundled/Data/Memory/MemMap/Posix.hsc @@ -0,0 +1,222 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Memory.MemMap.Posix +-- Copyright : (c) Vincent Hanquez 2014 +-- License : BSD-style +-- +-- Maintainer : Vincent Hanquez +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- Functions defined by the POSIX standards for manipulating memory maps +-- +-- When a function that calls an underlying POSIX function fails, the errno +-- code is converted to an 'IOError' using 'Foreign.C.Error.errnoToIOError'. +-- For a list of which errno codes may be generated, consult the POSIX +-- documentation for the underlying function. +-- +----------------------------------------------------------------------------- + +#include +#include + +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} +module Data.Memory.MemMap.Posix + ( memoryMap + , memoryUnmap + , memoryAdvise + , memoryLock + , memoryUnlock + , memoryProtect + , memorySync + -- * Flags types + , MemoryMapFlag(..) + , MemoryProtection(..) + , MemoryAdvice(..) + , MemorySyncFlag(..) + -- * system page size + , sysconfPageSize + ) where + +import System.Posix.Types +import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.Error +import Data.Bits + +foreign import ccall unsafe "mmap" + c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr a) + +foreign import ccall unsafe "munmap" + c_munmap :: Ptr a -> CSize -> IO CInt + +#if defined(POSIX_MADV_NORMAL) +foreign import ccall unsafe "posix_madvise" + c_madvise :: Ptr a -> CSize -> CInt -> IO CInt +#else +foreign import ccall unsafe "madvise" + c_madvise :: Ptr a -> CSize -> CInt -> IO CInt +#endif + +foreign import ccall unsafe "msync" + c_msync :: Ptr a -> CSize -> CInt -> IO CInt + +foreign import ccall unsafe "mprotect" + c_mprotect :: Ptr a -> CSize -> CInt -> IO CInt + +#ifndef __HAIKU__ +foreign import ccall unsafe "mlock" + c_mlock :: Ptr a -> CSize -> IO CInt +#else +c_mlock :: Ptr a -> CSize -> IO CInt +c_mlock _ _ = return (-1) +#endif + +#ifndef __HAIKU__ +foreign import ccall unsafe "munlock" + c_munlock :: Ptr a -> CSize -> IO CInt +#else +c_munlock :: Ptr a -> CSize -> IO CInt +c_munlock _ _ = return (-1) +#endif + +foreign import ccall unsafe "sysconf" + c_sysconf :: CInt -> CLong + +-- | Mapping flag +data MemoryMapFlag = + MemoryMapShared -- ^ memory changes are shared between process + | MemoryMapPrivate -- ^ memory changes are private to process + deriving (Show,Read,Eq) + +-- | Memory protection +data MemoryProtection = + MemoryProtectionNone + | MemoryProtectionRead + | MemoryProtectionWrite + | MemoryProtectionExecute + deriving (Show,Read,Eq) + +-- | Advice to put on memory. +-- +-- only define the posix one. +data MemoryAdvice = + MemoryAdviceNormal -- ^ no specific advice, the default. + | MemoryAdviceRandom -- ^ Expect page references in random order. No readahead should occur. + | MemoryAdviceSequential -- ^ Expect page references in sequential order. Page should be readahead aggressively. + | MemoryAdviceWillNeed -- ^ Expect access in the near future. Probably a good idea to readahead early + | MemoryAdviceDontNeed -- ^ Do not expect access in the near future. + deriving (Show,Read,Eq) + +-- | Memory synchronization flags +data MemorySyncFlag = + MemorySyncAsync -- ^ perform asynchronous write. + | MemorySyncSync -- ^ perform synchronous write. + | MemorySyncInvalidate -- ^ invalidate cache data. + deriving (Show,Read,Eq) + +cvalueOfMemoryProts :: [MemoryProtection] -> CInt +cvalueOfMemoryProts = foldl (.|.) 0 . map toProt + where toProt :: MemoryProtection -> CInt + toProt MemoryProtectionNone = (#const PROT_NONE) + toProt MemoryProtectionRead = (#const PROT_READ) + toProt MemoryProtectionWrite = (#const PROT_WRITE) + toProt MemoryProtectionExecute = (#const PROT_EXEC) + +cvalueOfMemorySync :: [MemorySyncFlag] -> CInt +cvalueOfMemorySync = foldl (.|.) 0 . map toSync + where toSync MemorySyncAsync = (#const MS_ASYNC) + toSync MemorySyncSync = (#const MS_SYNC) + toSync MemorySyncInvalidate = (#const MS_INVALIDATE) + +-- | Map pages of memory. +-- +-- If fd is present, this memory will represent the file associated. +-- Otherwise, the memory will be an anonymous mapping. +-- +-- use 'mmap' +memoryMap :: Maybe (Ptr a) -- ^ The address to map to if MapFixed is used. + -> CSize -- ^ The length of the mapping + -> [MemoryProtection] -- ^ the memory protection associated with the mapping + -> MemoryMapFlag -- ^ + -> Maybe Fd + -> COff + -> IO (Ptr a) +memoryMap initPtr sz prots flag mfd off = + throwErrnoIf (== m1ptr) "mmap" (c_mmap (maybe nullPtr id initPtr) sz cprot cflags fd off) + where m1ptr = nullPtr `plusPtr` (-1) + fd = maybe (-1) (\(Fd v) -> v) mfd + cprot = cvalueOfMemoryProts prots + cflags = maybe cMapAnon (const 0) mfd + .|. maybe 0 (const cMapFixed) initPtr + .|. toMapFlag flag + +#ifdef __APPLE__ + cMapAnon = (#const MAP_ANON) +#else + cMapAnon = (#const MAP_ANONYMOUS) +#endif + cMapFixed = (#const MAP_FIXED) + + toMapFlag MemoryMapShared = (#const MAP_SHARED) + toMapFlag MemoryMapPrivate = (#const MAP_PRIVATE) + +-- | Unmap pages of memory +-- +-- use 'munmap' +memoryUnmap :: Ptr a -> CSize -> IO () +memoryUnmap ptr sz = throwErrnoIfMinus1_ "munmap" (c_munmap ptr sz) + +-- | give advice to the operating system about use of memory +-- +-- call 'madvise' +memoryAdvise :: Ptr a -> CSize -> MemoryAdvice -> IO () +memoryAdvise ptr sz adv = throwErrnoIfMinus1_ "madvise" (c_madvise ptr sz cadv) + where cadv = toAdvice adv +#if defined(POSIX_MADV_NORMAL) + toAdvice MemoryAdviceNormal = (#const POSIX_MADV_NORMAL) + toAdvice MemoryAdviceRandom = (#const POSIX_MADV_RANDOM) + toAdvice MemoryAdviceSequential = (#const POSIX_MADV_SEQUENTIAL) + toAdvice MemoryAdviceWillNeed = (#const POSIX_MADV_WILLNEED) + toAdvice MemoryAdviceDontNeed = (#const POSIX_MADV_DONTNEED) +#else + toAdvice MemoryAdviceNormal = (#const MADV_NORMAL) + toAdvice MemoryAdviceRandom = (#const MADV_RANDOM) + toAdvice MemoryAdviceSequential = (#const MADV_SEQUENTIAL) + toAdvice MemoryAdviceWillNeed = (#const MADV_WILLNEED) + toAdvice MemoryAdviceDontNeed = (#const MADV_DONTNEED) +#endif + +-- | lock a range of process address space +-- +-- call 'mlock' +memoryLock :: Ptr a -> CSize -> IO () +memoryLock ptr sz = throwErrnoIfMinus1_ "mlock" (c_mlock ptr sz) + +-- | unlock a range of process address space +-- +-- call 'munlock' +memoryUnlock :: Ptr a -> CSize -> IO () +memoryUnlock ptr sz = throwErrnoIfMinus1_ "munlock" (c_munlock ptr sz) + +-- | set protection of memory mapping +-- +-- call 'mprotect' +memoryProtect :: Ptr a -> CSize -> [MemoryProtection] -> IO () +memoryProtect ptr sz prots = throwErrnoIfMinus1_ "mprotect" (c_mprotect ptr sz cprot) + where cprot = cvalueOfMemoryProts prots + +-- | memorySync synchronize memory with physical storage. +-- +-- On an anonymous mapping this function doesn't have any effect. +-- call 'msync' +memorySync :: Ptr a -> CSize -> [MemorySyncFlag] -> IO () +memorySync ptr sz flags = throwErrnoIfMinus1_ "msync" (c_msync ptr sz cflags) + where cflags = cvalueOfMemorySync flags + +-- | Return the operating system page size. +-- +-- call 'sysconf' +sysconfPageSize :: Int +sysconfPageSize = fromIntegral $ c_sysconf (#const _SC_PAGESIZE) diff --git a/bundled/Data/Memory/MemMap/Windows.hs b/bundled/Data/Memory/MemMap/Windows.hs new file mode 100644 index 0000000..931ff98 --- /dev/null +++ b/bundled/Data/Memory/MemMap/Windows.hs @@ -0,0 +1,12 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Memory.MemMap.Windows +-- Copyright : (c) Vincent Hanquez 2014 +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : provisional +-- Portability : non-portable (requires Windows) +-- +module Data.Memory.MemMap.Windows + ( + ) where diff --git a/bundled/Data/Memory/PtrMethods.hs b/bundled/Data/Memory/PtrMethods.hs new file mode 100644 index 0000000..88b4328 --- /dev/null +++ b/bundled/Data/Memory/PtrMethods.hs @@ -0,0 +1,120 @@ +-- | +-- Module : Data.Memory.PtrMethods +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- methods to manipulate raw memory representation +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Data.Memory.PtrMethods + ( memCreateTemporary + , memXor + , memXorWith + , memCopy + , memSet + , memReverse + , memEqual + , memConstEqual + , memCompare + ) where + +import Data.Memory.Internal.Imports +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (peek, poke, peekByteOff) +import Foreign.C.Types +import Foreign.Marshal.Alloc (allocaBytesAligned) +import Data.Bits ((.|.), xor) + +-- | Create a new temporary buffer +memCreateTemporary :: Int -> (Ptr Word8 -> IO a) -> IO a +memCreateTemporary size f = allocaBytesAligned size 8 f + +-- | xor bytes from source1 and source2 to destination +-- +-- d = s1 xor s2 +-- +-- s1, nor s2 are modified unless d point to s1 or s2 +memXor :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Int -> IO () +memXor _ _ _ 0 = return () +memXor d s1 s2 n = do + (xor <$> peek s1 <*> peek s2) >>= poke d + memXor (d `plusPtr` 1) (s1 `plusPtr` 1) (s2 `plusPtr` 1) (n-1) + +-- | xor bytes from source with a specific value to destination +-- +-- d = replicate (sizeof s) v `xor` s +memXorWith :: Ptr Word8 -> Word8 -> Ptr Word8 -> Int -> IO () +memXorWith destination !v source bytes + | destination == source = loopInplace source bytes + | otherwise = loop destination source bytes + where + loop !d !s n = when (n > 0) $ do + peek s >>= poke d . xor v + loop (d `plusPtr` 1) (s `plusPtr` 1) (n-1) + + loopInplace !s n = when (n > 0) $ do + peek s >>= poke s . xor v + loopInplace (s `plusPtr` 1) (n-1) + +-- | Copy a set number of bytes from @src to @dst +memCopy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () +memCopy dst src n = c_memcpy dst src (fromIntegral n) +{-# INLINE memCopy #-} + +-- | Set @n number of bytes to the same value @v +memSet :: Ptr Word8 -> Word8 -> Int -> IO () +memSet start v n = c_memset start v (fromIntegral n) >>= \_ -> return () +{-# INLINE memSet #-} + +-- | Reverse a set number of bytes from @src@ to @dst@. Memory +-- locations should not overlap. +memReverse :: Ptr Word8 -> Ptr Word8 -> Int -> IO () +memReverse d s n + | n > 0 = do peekByteOff s (n - 1) >>= poke d + memReverse (d `plusPtr` 1) s (n - 1) + | otherwise = return () + +-- | Check if two piece of memory are equals +memEqual :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool +memEqual p1 p2 n = loop 0 + where + loop i + | i == n = return True + | otherwise = do + e <- (==) <$> peekByteOff p1 i <*> (peekByteOff p2 i :: IO Word8) + if e then loop (i+1) else return False + +-- | Compare two piece of memory and returns how they compare +memCompare :: Ptr Word8 -> Ptr Word8 -> Int -> IO Ordering +memCompare p1 p2 n = loop 0 + where + loop i + | i == n = return EQ + | otherwise = do + e <- compare <$> peekByteOff p1 i <*> (peekByteOff p2 i :: IO Word8) + if e == EQ then loop (i+1) else return e + +-- | A constant time equality test for 2 Memory buffers +-- +-- compared to normal equality function, this function will go +-- over all the bytes present before yielding a result even when +-- knowing the overall result early in the processing. +memConstEqual :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool +memConstEqual p1 p2 n = loop 0 0 + where + loop i !acc + | i == n = return $! acc == 0 + | otherwise = do + e <- xor <$> peekByteOff p1 i <*> (peekByteOff p2 i :: IO Word8) + loop (i+1) (acc .|. e) + +foreign import ccall unsafe "memset" + c_memset :: Ptr Word8 -> Word8 -> CSize -> IO () + +foreign import ccall unsafe "memcpy" + c_memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO () diff --git a/bundled/Data/Scientific.hs b/bundled/Data/Scientific.hs new file mode 100644 index 0000000..ff4f24f --- /dev/null +++ b/bundled/Data/Scientific.hs @@ -0,0 +1,1095 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | +-- Module : Data.Scientific +-- Copyright : Bas van Dijk 2013 +-- License : BSD3 +-- Maintainer : Bas van Dijk +-- +-- This module provides the number type 'Scientific'. Scientific numbers are +-- arbitrary precision and space efficient. They are represented using +-- . The +-- implementation uses an 'Integer' 'coefficient' @c@ and an 'Int' +-- 'base10Exponent' @e@. A scientific number corresponds to the 'Fractional' +-- number: @'fromInteger' c * 10 '^^' e@. +-- +-- Note that since we're using an 'Int' to represent the exponent these numbers +-- aren't truly arbitrary precision. I intend to change the type of the exponent +-- to 'Integer' in a future release. +-- +-- /WARNING:/ Although @Scientific@ has instances for all numeric classes the +-- methods should be used with caution when applied to scientific numbers coming +-- from untrusted sources. See the warnings of the instances belonging to +-- 'Scientific'. +-- +-- The main application of 'Scientific' is to be used as the target of parsing +-- arbitrary precision numbers coming from an untrusted source. The advantages +-- over using 'Rational' for this are that: +-- +-- * A 'Scientific' is more efficient to construct. Rational numbers need to be +-- constructed using '%' which has to compute the 'gcd' of the 'numerator' and +-- 'denominator'. +-- +-- * 'Scientific' is safe against numbers with huge exponents. For example: +-- @1e1000000000 :: 'Rational'@ will fill up all space and crash your +-- program. Scientific works as expected: +-- +-- > > read "1e1000000000" :: Scientific +-- > 1.0e1000000000 +-- +-- * Also, the space usage of converting scientific numbers with huge exponents +-- to @'Integral's@ (like: 'Int') or @'RealFloat's@ (like: 'Double' or 'Float') +-- will always be bounded by the target type. +-- +-- This module is designed to be imported qualified: +-- +-- @import qualified Data.Scientific as Scientific@ +module Data.Scientific + ( Scientific + + -- * Construction + , scientific + + -- * Projections + , coefficient + , base10Exponent + + -- * Predicates + , isFloating + , isInteger + + -- * Conversions + -- ** Rational + , unsafeFromRational + , fromRationalRepetend + , fromRationalRepetendLimited + , fromRationalRepetendUnlimited + , toRationalRepetend + + -- ** Floating & integer + , floatingOrInteger + , toRealFloat + , toBoundedRealFloat + , toBoundedInteger + , fromFloatDigits + + -- * Parsing + , scientificP + + -- * Pretty printing + , formatScientific + , FPFormat(..) + + , toDecimalDigits + + -- * Normalization + , normalize + ) where + + +---------------------------------------------------------------------- +-- Imports +---------------------------------------------------------------------- + +import Control.Exception (throw, ArithException(DivideByZero)) +import Control.Monad (mplus) +import Control.DeepSeq (NFData, rnf) +import Data.Binary (Binary, get, put) +import Data.Char (intToDigit, ord) +import Data.Data (Data) +import Data.Int (Int8, Int16, Int32, Int64) +import qualified Data.Map as M (Map, empty, insert, lookup) +import Data.Ratio ((%), numerator, denominator) +import Data.Typeable (Typeable) +import Data.Word (Word8, Word16, Word32, Word64) +import Math.NumberTheory.Logarithms (integerLog10') +import qualified Numeric (floatToDigits) +import qualified Text.Read as Read +import Text.Read (readPrec) +import qualified Text.ParserCombinators.ReadPrec as ReadPrec +import qualified Text.ParserCombinators.ReadP as ReadP +import Text.ParserCombinators.ReadP ( ReadP ) +import Data.Text.Lazy.Builder.RealFloat (FPFormat(..)) + +import GHC.Integer.Compat (quotRemInteger, quotInteger, divInteger) +import Utils (maxExpt, roundTo, magnitude) + +import Language.Haskell.TH.Syntax (Lift (..)) + +---------------------------------------------------------------------- +-- Type +---------------------------------------------------------------------- + +-- | An arbitrary-precision number represented using +-- . +-- +-- This type describes the set of all @'Real's@ which have a finite +-- decimal expansion. +-- +-- A scientific number with 'coefficient' @c@ and 'base10Exponent' @e@ +-- corresponds to the 'Fractional' number: @'fromInteger' c * 10 '^^' e@ +data Scientific = Scientific + { coefficient :: !Integer + -- ^ The coefficient of a scientific number. + -- + -- Note that this number is not necessarily normalized, i.e. + -- it could contain trailing zeros. + -- + -- Scientific numbers are automatically normalized when pretty printed or + -- in 'toDecimalDigits'. + -- + -- Use 'normalize' to do manual normalization. + -- + -- /WARNING:/ 'coefficient' and 'base10exponent' violate + -- substantivity of 'Eq'. + -- + -- >>> let x = scientific 1 2 + -- >>> let y = scientific 100 0 + -- >>> x == y + -- True + -- + -- but + -- + -- >>> (coefficient x == coefficient y, base10Exponent x == base10Exponent y) + -- (False,False) + -- + + , base10Exponent :: {-# UNPACK #-} !Int + -- ^ The base-10 exponent of a scientific number. + } deriving (Typeable, Data) + +-- | @scientific c e@ constructs a scientific number which corresponds +-- to the 'Fractional' number: @'fromInteger' c * 10 '^^' e@. +scientific :: Integer -> Int -> Scientific +scientific = Scientific + +---------------------------------------------------------------------- +-- Instances +---------------------------------------------------------------------- + +-- | @since 0.3.7.0 +deriving instance Lift Scientific + +instance NFData Scientific where + rnf (Scientific _ _) = () + +-- | Note that in the future I intend to change the type of the 'base10Exponent' +-- from @Int@ to @Integer@. To be forward compatible the @Binary@ instance +-- already encodes the exponent as 'Integer'. +instance Binary Scientific where + put (Scientific c e) = put c *> put (toInteger e) + get = Scientific <$> get <*> (fromInteger <$> get) + +-- | Scientific numbers can be safely compared for equality. No magnitude @10^e@ +-- is calculated so there's no risk of a blowup in space or time when comparing +-- scientific numbers coming from untrusted sources. +instance Eq Scientific where + s1 == s2 = c1 == c2 && e1 == e2 + where + Scientific c1 e1 = normalize s1 + Scientific c2 e2 = normalize s2 + +-- | Scientific numbers can be safely compared for ordering. No magnitude @10^e@ +-- is calculated so there's no risk of a blowup in space or time when comparing +-- scientific numbers coming from untrusted sources. +instance Ord Scientific where + compare s1 s2 + | c1 == c2 && e1 == e2 = EQ + | c1 < 0 = if c2 < 0 then cmp (-c2) e2 (-c1) e1 else LT + | c1 > 0 = if c2 > 0 then cmp c1 e1 c2 e2 else GT + | otherwise = if c2 > 0 then LT else GT + where + Scientific c1 e1 = normalize s1 + Scientific c2 e2 = normalize s2 + + cmp cx ex cy ey + | log10sx < log10sy = LT + | log10sx > log10sy = GT + | d < 0 = if cx <= (cy `quotInteger` magnitude (-d)) then LT else GT + | d > 0 = if cy > (cx `quotInteger` magnitude d) then LT else GT + | otherwise = if cx < cy then LT else GT + where + log10sx = log10cx + ex + log10sy = log10cy + ey + + log10cx = integerLog10' cx + log10cy = integerLog10' cy + + d = log10cx - log10cy + +-- | /WARNING:/ '+' and '-' compute the 'Integer' magnitude: @10^e@ where @e@ is +-- the difference between the @'base10Exponent's@ of the arguments. If these +-- methods are applied to arguments which have huge exponents this could fill up +-- all space and crash your program! So don't apply these methods to scientific +-- numbers coming from untrusted sources. The other methods can be used safely. +instance Num Scientific where + Scientific c1 e1 + Scientific c2 e2 + | e1 < e2 = Scientific (c1 + c2*l) e1 + | otherwise = Scientific (c1*r + c2 ) e2 + where + l = magnitude (e2 - e1) + r = magnitude (e1 - e2) + {-# INLINABLE (+) #-} + + Scientific c1 e1 - Scientific c2 e2 + | e1 < e2 = Scientific (c1 - c2*l) e1 + | otherwise = Scientific (c1*r - c2 ) e2 + where + l = magnitude (e2 - e1) + r = magnitude (e1 - e2) + {-# INLINABLE (-) #-} + + Scientific c1 e1 * Scientific c2 e2 = + Scientific (c1 * c2) (e1 + e2) + {-# INLINABLE (*) #-} + + abs (Scientific c e) = Scientific (abs c) e + {-# INLINABLE abs #-} + + negate (Scientific c e) = Scientific (negate c) e + {-# INLINABLE negate #-} + + signum (Scientific c _) = Scientific (signum c) 0 + {-# INLINABLE signum #-} + + fromInteger i = Scientific i 0 + {-# INLINABLE fromInteger #-} + +-- | /WARNING:/ 'toRational' needs to compute the 'Integer' magnitude: +-- @10^e@. If applied to a huge exponent this could fill up all space +-- and crash your program! +-- +-- Avoid applying 'toRational' (or 'realToFrac') to scientific numbers +-- coming from an untrusted source and use 'toRealFloat' instead. The +-- latter guards against excessive space usage. +instance Real Scientific where + toRational (Scientific c e) + | e < 0 = c % magnitude (-e) + | otherwise = (c * magnitude e) % 1 + {-# INLINABLE toRational #-} + +{-# RULES + "realToFrac_toRealFloat_Double" + realToFrac = toRealFloat :: Scientific -> Double #-} + +{-# RULES + "realToFrac_toRealFloat_Float" + realToFrac = toRealFloat :: Scientific -> Float #-} + +-- | /WARNING:/ 'recip' and '/' will throw an error when their outputs are +-- . +-- +-- These methods also compute 'Integer' magnitudes (@10^e@). If these methods +-- are applied to arguments which have huge exponents this could fill up all +-- space and crash your program! So don't apply these methods to scientific +-- numbers coming from untrusted sources. +-- +-- 'fromRational' will throw an error when the input 'Rational' is a repeating +-- decimal. Consider using 'fromRationalRepetend' for these rationals which +-- will detect the repetition and indicate where it starts. +instance Fractional Scientific where + recip = fromRational . recip . toRational + + Scientific c1 e1 / Scientific c2 e2 + | d < 0 = fromRational (x / (fromInteger (magnitude (-d)))) + | otherwise = fromRational (x * fromInteger (magnitude d)) + where + d = e1 - e2 + x = c1 % c2 + + fromRational rational = + case mbRepetendIx of + Nothing -> s + Just _ix -> error $ + "fromRational has been applied to a repeating decimal " ++ + "which can't be represented as a Scientific! " ++ + "It's better to avoid performing fractional operations on Scientifics " ++ + "and convert them to other fractional types like Double as early as possible." + where + (s, mbRepetendIx) = fromRationalRepetendUnlimited rational + +-- | Although 'fromRational' is unsafe because it will throw errors on +-- , +-- @unsafeFromRational@ is even more unsafe because it will diverge instead (i.e +-- loop and consume all space). Though it will be more efficient because it +-- doesn't need to consume space linear in the number of digits in the resulting +-- scientific to detect the repetition. +-- +-- Consider using 'fromRationalRepetend' for these rationals which will detect +-- the repetition and indicate where it starts. +unsafeFromRational :: Rational -> Scientific +unsafeFromRational rational + | d == 0 = throw DivideByZero + | otherwise = positivize (longDiv 0 0) (numerator rational) + where + -- Divide the numerator by the denominator using long division. + longDiv :: Integer -> Int -> (Integer -> Scientific) + longDiv !c !e 0 = Scientific c e + longDiv !c !e !n + -- TODO: Use a logarithm here! + | n < d = longDiv (c * 10) (e - 1) (n * 10) + | otherwise = case n `quotRemInteger` d of + (#q, r#) -> longDiv (c + q) e r + + d = denominator rational + +-- | Like 'fromRational' and 'unsafeFromRational', this function converts a +-- `Rational` to a `Scientific` but instead of failing or diverging (i.e loop +-- and consume all space) on +-- +-- it detects the repeating part, the /repetend/, and returns where it starts. +-- +-- To detect the repetition this function consumes space linear in the number of +-- digits in the resulting scientific. In order to bound the space usage an +-- optional limit can be specified. If the number of digits reaches this limit +-- @Left (s, r)@ will be returned. Here @s@ is the 'Scientific' constructed so +-- far and @r@ is the remaining 'Rational'. @toRational s + r@ yields the +-- original 'Rational' +-- +-- If the limit is not reached or no limit was specified @Right (s, +-- mbRepetendIx)@ will be returned. Here @s@ is the 'Scientific' without any +-- repetition and @mbRepetendIx@ specifies if and where in the fractional part +-- the repetend begins. +-- +-- For example: +-- +-- @fromRationalRepetend Nothing (1 % 28) == Right (3.571428e-2, Just 2)@ +-- +-- This represents the repeating decimal: @0.03571428571428571428...@ +-- which is sometimes also unambiguously denoted as @0.03(571428)@. +-- Here the repetend is enclosed in parentheses and starts at the 3rd digit (index 2) +-- in the fractional part. Specifying a limit results in the following: +-- +-- @fromRationalRepetend (Just 4) (1 % 28) == Left (3.5e-2, 1 % 1400)@ +-- +-- You can expect the following property to hold. +-- +-- @ forall (mbLimit :: Maybe Int) (r :: Rational). +-- r == (case 'fromRationalRepetend' mbLimit r of +-- Left (s, r') -> toRational s + r' +-- Right (s, mbRepetendIx) -> +-- case mbRepetendIx of +-- Nothing -> toRational s +-- Just repetendIx -> 'toRationalRepetend' s repetendIx) +-- @ +fromRationalRepetend + :: Maybe Int -- ^ Optional limit + -> Rational + -> Either (Scientific, Rational) + (Scientific, Maybe Int) +fromRationalRepetend mbLimit rational = + case mbLimit of + Nothing -> Right $ fromRationalRepetendUnlimited rational + Just l -> fromRationalRepetendLimited l rational + +-- | Like 'fromRationalRepetend' but always accepts a limit. +fromRationalRepetendLimited + :: Int -- ^ limit + -> Rational + -> Either (Scientific, Rational) + (Scientific, Maybe Int) +fromRationalRepetendLimited l rational + | d == 0 = throw DivideByZero + | num < 0 = case longDiv (-num) of + Left (s, r) -> Left (-s, -r) + Right (s, mb) -> Right (-s, mb) + | otherwise = longDiv num + where + num = numerator rational + + longDiv :: Integer -> Either (Scientific, Rational) (Scientific, Maybe Int) + longDiv = longDivWithLimit 0 0 M.empty + + longDivWithLimit + :: Integer + -> Int + -> M.Map Integer Int + -> (Integer -> Either (Scientific, Rational) + (Scientific, Maybe Int)) + longDivWithLimit !c !e _ns 0 = Right (Scientific c e, Nothing) + longDivWithLimit !c !e ns !n + | Just e' <- M.lookup n ns = Right (Scientific c e, Just (-e')) + | e <= (-l) = Left (Scientific c e, n % (d * magnitude (-e))) + | n < d = let !ns' = M.insert n e ns + in longDivWithLimit (c * 10) (e - 1) ns' (n * 10) + | otherwise = case n `quotRemInteger` d of + (#q, r#) -> longDivWithLimit (c + q) e ns r + + d = denominator rational + +-- | Like 'fromRationalRepetend' but doesn't accept a limit. +fromRationalRepetendUnlimited :: Rational -> (Scientific, Maybe Int) +fromRationalRepetendUnlimited rational + | d == 0 = throw DivideByZero + | num < 0 = case longDiv (-num) of + (s, mb) -> (-s, mb) + | otherwise = longDiv num + where + num = numerator rational + + longDiv :: Integer -> (Scientific, Maybe Int) + longDiv = longDivNoLimit 0 0 M.empty + + longDivNoLimit :: Integer + -> Int + -> M.Map Integer Int + -> (Integer -> (Scientific, Maybe Int)) + longDivNoLimit !c !e _ns 0 = (Scientific c e, Nothing) + longDivNoLimit !c !e ns !n + | Just e' <- M.lookup n ns = (Scientific c e, Just (-e')) + | n < d = let !ns' = M.insert n e ns + in longDivNoLimit (c * 10) (e - 1) ns' (n * 10) + | otherwise = case n `quotRemInteger` d of + (#q, r#) -> longDivNoLimit (c + q) e ns r + + d = denominator rational + +-- | +-- Converts a `Scientific` with a /repetend/ (a repeating part in the fraction), +-- which starts at the given index, into its corresponding 'Rational'. +-- +-- For example to convert the repeating decimal @0.03(571428)@ you would use: +-- @toRationalRepetend 0.03571428 2 == 1 % 28@ +-- +-- Preconditions for @toRationalRepetend s r@: +-- +-- * @r >= 0@ +-- +-- * @r < -(base10Exponent s)@ +-- +-- /WARNING:/ @toRationalRepetend@ needs to compute the 'Integer' magnitude: +-- @10^^n@. Where @n@ is based on the 'base10Exponent` of the scientific. If +-- applied to a huge exponent this could fill up all space and crash your +-- program! So don't apply this function to untrusted input. +-- +-- The formula to convert the @Scientific@ @s@ +-- with a repetend starting at index @r@ is described in the paper: +-- +-- and is defined as follows: +-- +-- @ +-- (fromInteger nonRepetend + repetend % nines) / +-- fromInteger (10^^r) +-- where +-- c = coefficient s +-- e = base10Exponent s +-- +-- -- Size of the fractional part. +-- f = (-e) +-- +-- -- Size of the repetend. +-- n = f - r +-- +-- m = 10^^n +-- +-- (nonRepetend, repetend) = c \`quotRem\` m +-- +-- nines = m - 1 +-- @ +-- Also see: 'fromRationalRepetend'. +toRationalRepetend + :: Scientific + -> Int -- ^ Repetend index + -> Rational +toRationalRepetend s r + | r < 0 = error "toRationalRepetend: Negative repetend index!" + | r >= f = error "toRationalRepetend: Repetend index >= than number of digits in the fractional part!" + | otherwise = (fromInteger nonRepetend + repetend % nines) / + fromInteger (magnitude r) + where + c = coefficient s + e = base10Exponent s + + -- Size of the fractional part. + f = (-e) + + -- Size of the repetend. + n = f - r + + m = magnitude n + + (#nonRepetend, repetend#) = c `quotRemInteger` m + + nines = m - 1 + +-- | /WARNING:/ the methods of the @RealFrac@ instance need to compute the +-- magnitude @10^e@. If applied to a huge exponent this could take a long +-- time. Even worse, when the destination type is unbounded (i.e. 'Integer') it +-- could fill up all space and crash your program! +instance RealFrac Scientific where + -- | The function 'properFraction' takes a Scientific number @s@ + -- and returns a pair @(n,f)@ such that @s = n+f@, and: + -- + -- * @n@ is an integral number with the same sign as @s@; and + -- + -- * @f@ is a fraction with the same type and sign as @s@, + -- and with absolute value less than @1@. + properFraction s@(Scientific c e) + | e < 0 = if dangerouslySmall c e + then (0, s) + else case c `quotRemInteger` magnitude (-e) of + (#q, r#) -> (fromInteger q, Scientific r e) + | otherwise = (toIntegral s, 0) + {-# INLINABLE properFraction #-} + + -- | @'truncate' s@ returns the integer nearest @s@ + -- between zero and @s@ + truncate = whenFloating $ \c e -> + if dangerouslySmall c e + then 0 + else fromInteger $ c `quotInteger` magnitude (-e) + {-# INLINABLE truncate #-} + + -- | @'round' s@ returns the nearest integer to @s@; + -- the even integer if @s@ is equidistant between two integers + round = whenFloating $ \c e -> + if dangerouslySmall c e + then 0 + else let (#q, r#) = c `quotRemInteger` magnitude (-e) + n = fromInteger q + m | r < 0 = n - 1 + | otherwise = n + 1 + f = Scientific r e + in case signum $ coefficient $ abs f - 0.5 of + -1 -> n + 0 -> if even n then n else m + 1 -> m + _ -> error "round default defn: Bad value" + {-# INLINABLE round #-} + + -- | @'ceiling' s@ returns the least integer not less than @s@ + ceiling = whenFloating $ \c e -> + if dangerouslySmall c e + then if c <= 0 + then 0 + else 1 + else case c `quotRemInteger` magnitude (-e) of + (#q, r#) | r <= 0 -> fromInteger q + | otherwise -> fromInteger (q + 1) + {-# INLINABLE ceiling #-} + + -- | @'floor' s@ returns the greatest integer not greater than @s@ + floor = whenFloating $ \c e -> + if dangerouslySmall c e + then if c < 0 + then -1 + else 0 + else fromInteger (c `divInteger` magnitude (-e)) + {-# INLINABLE floor #-} + + +---------------------------------------------------------------------- +-- Internal utilities +---------------------------------------------------------------------- + +-- | This function is used in the 'RealFrac' methods to guard against +-- computing a huge magnitude (-e) which could take up all space. +-- +-- Think about parsing a scientific number from an untrusted +-- string. An attacker could supply 1e-1000000000. Lets say we want to +-- 'floor' that number to an 'Int'. When we naively try to floor it +-- using: +-- +-- @ +-- floor = whenFloating $ \c e -> +-- fromInteger (c `div` magnitude (-e)) +-- @ +-- +-- We will compute the huge Integer: @magnitude 1000000000@. This +-- computation will quickly fill up all space and crash the program. +-- +-- Note that for large /positive/ exponents there is no risk of a +-- space-leak since 'whenFloating' will compute: +-- +-- @fromInteger c * magnitude e :: a@ +-- +-- where @a@ is the target type (Int in this example). So here the +-- space usage is bounded by the target type. +-- +-- For large negative exponents we check if the exponent is smaller +-- than some limit (currently -324). In that case we know that the +-- scientific number is really small (unless the coefficient has many +-- digits) so we can immediately return -1 for negative scientific +-- numbers or 0 for positive numbers. +-- +-- More precisely if @dangerouslySmall c e@ returns 'True' the +-- scientific number @s@ is guaranteed to be between: +-- @-0.1 > s < 0.1@. +-- +-- Note that we avoid computing the number of decimal digits in c +-- (log10 c) if the exponent is not below the limit. +dangerouslySmall :: Integer -> Int -> Bool +dangerouslySmall c e = e < (-limit) && e < (-integerLog10' (abs c)) - 1 +{-# INLINE dangerouslySmall #-} + +limit :: Int +limit = maxExpt + +positivize :: (Ord a, Num a, Num b) => (a -> b) -> (a -> b) +positivize f x | x < 0 = -(f (-x)) + | otherwise = f x +{-# INLINE positivize #-} + +whenFloating :: (Num a) => (Integer -> Int -> a) -> Scientific -> a +whenFloating f s@(Scientific c e) + | e < 0 = f c e + | otherwise = toIntegral s +{-# INLINE whenFloating #-} + +-- | Precondition: the 'Scientific' @s@ needs to be an integer: +-- @base10Exponent (normalize s) >= 0@ +toIntegral :: (Num a) => Scientific -> a +toIntegral (Scientific c e) = fromInteger c * magnitude e +{-# INLINE toIntegral #-} + + + + + + +---------------------------------------------------------------------- +-- Conversions +---------------------------------------------------------------------- + +-- | Convert a 'RealFloat' (like a 'Double' or 'Float') into a 'Scientific' +-- number. +-- +-- Note that this function uses 'Numeric.floatToDigits' to compute the digits +-- and exponent of the 'RealFloat' number. Be aware that the algorithm used in +-- 'Numeric.floatToDigits' doesn't work as expected for some numbers, e.g. as +-- the 'Double' @1e23@ is converted to @9.9999999999999991611392e22@, and that +-- value is shown as @9.999999999999999e22@ rather than the shorter @1e23@; the +-- algorithm doesn't take the rounding direction for values exactly half-way +-- between two adjacent representable values into account, so if you have a +-- value with a short decimal representation exactly half-way between two +-- adjacent representable values, like @5^23*2^e@ for @e@ close to 23, the +-- algorithm doesn't know in which direction the short decimal representation +-- would be rounded and computes more digits +fromFloatDigits :: (RealFloat a) => a -> Scientific +fromFloatDigits 0 = 0 +fromFloatDigits rf = positivize fromPositiveRealFloat rf + where + fromPositiveRealFloat r = go digits 0 0 + where + (digits, e) = Numeric.floatToDigits 10 r + + go :: [Int] -> Integer -> Int -> Scientific + go [] !c !n = Scientific c (e - n) + go (d:ds) !c !n = go ds (c * 10 + toInteger d) (n + 1) + +{-# INLINABLE fromFloatDigits #-} + +{-# SPECIALIZE fromFloatDigits :: Double -> Scientific #-} +{-# SPECIALIZE fromFloatDigits :: Float -> Scientific #-} + +-- | Safely convert a 'Scientific' number into a 'RealFloat' (like a 'Double' or a +-- 'Float'). +-- +-- Note that this function uses 'realToFrac' (@'fromRational' . 'toRational'@) +-- internally but it guards against computing huge Integer magnitudes (@10^e@) +-- that could fill up all space and crash your program. If the 'base10Exponent' +-- of the given 'Scientific' is too big or too small to be represented in the +-- target type, Infinity or 0 will be returned respectively. Use +-- 'toBoundedRealFloat' which explicitly handles this case by returning 'Left'. +-- +-- Always prefer 'toRealFloat' over 'realToFrac' when converting from scientific +-- numbers coming from an untrusted source. +toRealFloat :: (RealFloat a) => Scientific -> a +toRealFloat = either id id . toBoundedRealFloat + +{-# INLINABLE toRealFloat #-} +{-# INLINABLE toBoundedRealFloat #-} + +{-# SPECIALIZE toRealFloat :: Scientific -> Double #-} +{-# SPECIALIZE toRealFloat :: Scientific -> Float #-} +{-# SPECIALIZE toBoundedRealFloat :: Scientific -> Either Double Double #-} +{-# SPECIALIZE toBoundedRealFloat :: Scientific -> Either Float Float #-} + +-- | Preciser version of `toRealFloat`. If the 'base10Exponent' of the given +-- 'Scientific' is too big or too small to be represented in the target type, +-- Infinity or 0 will be returned as 'Left'. +toBoundedRealFloat :: forall a. (RealFloat a) => Scientific -> Either a a +toBoundedRealFloat s@(Scientific c e) + | c == 0 = Right 0 + | e > limit = if e > hiLimit then Left $ sign (1/0) -- Infinity + else Right $ fromRational ((c * magnitude e) % 1) + | e < -limit = if e < loLimit && e + d < loLimit then Left $ sign 0 + else Right $ fromRational (c % magnitude (-e)) + | otherwise = Right $ fromRational (toRational s) + -- We can't use realToFrac here + -- because that will cause an infinite loop + -- when the function is specialized for Double and Float + -- caused by the realToFrac_toRealFloat_Double/Float rewrite RULEs. + where + hiLimit, loLimit :: Int + hiLimit = ceiling (fromIntegral hi * log10Radix) + loLimit = floor (fromIntegral lo * log10Radix) - + ceiling (fromIntegral digits * log10Radix) + + log10Radix :: Double + log10Radix = logBase 10 $ fromInteger radix + + radix = floatRadix (undefined :: a) + digits = floatDigits (undefined :: a) + (lo, hi) = floatRange (undefined :: a) + + d = integerLog10' (abs c) + + sign x | c < 0 = -x + | otherwise = x + +-- | Convert a `Scientific` to a bounded integer. +-- +-- If the given `Scientific` doesn't fit in the target representation, it will +-- return `Nothing`. +-- +-- This function also guards against computing huge Integer magnitudes (@10^e@) +-- that could fill up all space and crash your program. +toBoundedInteger :: forall i. (Integral i, Bounded i) => Scientific -> Maybe i +toBoundedInteger s + | c == 0 = fromIntegerBounded 0 + | integral = if dangerouslyBig + then Nothing + else fromIntegerBounded n + | otherwise = Nothing + where + c = coefficient s + + integral = e >= 0 || e' >= 0 + + e = base10Exponent s + e' = base10Exponent s' + + s' = normalize s + + dangerouslyBig = e > limit && + e > integerLog10' (max (abs iMinBound) (abs iMaxBound)) + + fromIntegerBounded :: Integer -> Maybe i + fromIntegerBounded i + | i < iMinBound || i > iMaxBound = Nothing + | otherwise = Just $ fromInteger i + + iMinBound = toInteger (minBound :: i) + iMaxBound = toInteger (maxBound :: i) + + -- This should not be evaluated if the given Scientific is dangerouslyBig + -- since it could consume all space and crash the process: + n :: Integer + n = toIntegral s' + +{-# SPECIALIZE toBoundedInteger :: Scientific -> Maybe Int #-} +{-# SPECIALIZE toBoundedInteger :: Scientific -> Maybe Int8 #-} +{-# SPECIALIZE toBoundedInteger :: Scientific -> Maybe Int16 #-} +{-# SPECIALIZE toBoundedInteger :: Scientific -> Maybe Int32 #-} +{-# SPECIALIZE toBoundedInteger :: Scientific -> Maybe Int64 #-} +{-# SPECIALIZE toBoundedInteger :: Scientific -> Maybe Word #-} +{-# SPECIALIZE toBoundedInteger :: Scientific -> Maybe Word8 #-} +{-# SPECIALIZE toBoundedInteger :: Scientific -> Maybe Word16 #-} +{-# SPECIALIZE toBoundedInteger :: Scientific -> Maybe Word32 #-} +{-# SPECIALIZE toBoundedInteger :: Scientific -> Maybe Word64 #-} + +-- | @floatingOrInteger@ determines if the scientific is floating point or +-- integer. +-- +-- In case it's floating-point the scientific is converted to the desired +-- 'RealFloat' using 'toRealFloat' and wrapped in 'Left'. +-- +-- In case it's integer to scientific is converted to the desired 'Integral' and +-- wrapped in 'Right'. +-- +-- /WARNING:/ To convert the scientific to an integral the magnitude @10^e@ +-- needs to be computed. If applied to a huge exponent this could take a long +-- time. Even worse, when the destination type is unbounded (i.e. 'Integer') it +-- could fill up all space and crash your program! So don't apply this function +-- to untrusted input but use 'toBoundedInteger' instead. +-- +-- Also see: 'isFloating' or 'isInteger'. +floatingOrInteger :: (RealFloat r, Integral i) => Scientific -> Either r i +floatingOrInteger s + | base10Exponent s >= 0 = Right (toIntegral s) + | base10Exponent s' >= 0 = Right (toIntegral s') + | otherwise = Left (toRealFloat s') + where + s' = normalize s + + +---------------------------------------------------------------------- +-- Predicates +---------------------------------------------------------------------- + +-- | Return 'True' if the scientific is a floating point, 'False' otherwise. +-- +-- Also see: 'floatingOrInteger'. +isFloating :: Scientific -> Bool +isFloating = not . isInteger + +-- | Return 'True' if the scientific is an integer, 'False' otherwise. +-- +-- Also see: 'floatingOrInteger'. +isInteger :: Scientific -> Bool +isInteger s = base10Exponent s >= 0 || + base10Exponent s' >= 0 + where + s' = normalize s + + +---------------------------------------------------------------------- +-- Parsing +---------------------------------------------------------------------- + +-- | Supports the skipping of parentheses and whitespaces. Example: +-- +-- > > read " ( (( -1.0e+3 ) ))" :: Scientific +-- > -1000.0 +-- +-- (Note: This @Read@ instance makes internal use of +-- 'scientificP' to parse the floating-point number.) +instance Read Scientific where + readPrec = Read.parens $ ReadPrec.lift (ReadP.skipSpaces >> scientificP) + +-- A strict pair +data SP = SP !Integer {-# UNPACK #-}!Int + +-- | A parser for parsing a floating-point +-- number into a 'Scientific' value. Example: +-- +-- > > import Text.ParserCombinators.ReadP (readP_to_S) +-- > > readP_to_S scientificP "3" +-- > [(3.0,"")] +-- > > readP_to_S scientificP "3.0e2" +-- > [(3.0,"e2"),(300.0,"")] +-- > > readP_to_S scientificP "+3.0e+2" +-- > [(3.0,"e+2"),(300.0,"")] +-- > > readP_to_S scientificP "-3.0e-2" +-- > [(-3.0,"e-2"),(-3.0e-2,"")] +-- +-- Note: This parser only parses the number itself; it does +-- not parse any surrounding parentheses or whitespaces. +scientificP :: ReadP Scientific +scientificP = do + let positive = (('+' ==) <$> ReadP.satisfy isSign) `mplus` return True + pos <- positive + + let step :: Num a => a -> Int -> a + step a digit = a * 10 + fromIntegral digit + {-# INLINE step #-} + + n <- foldDigits step 0 + + let s = SP n 0 + fractional = foldDigits (\(SP a e) digit -> + SP (step a digit) (e-1)) s + + SP coeff expnt <- (ReadP.satisfy (== '.') >> fractional) + ReadP.<++ return s + + let signedCoeff | pos = coeff + | otherwise = (-coeff) + + eP = do posE <- positive + e <- foldDigits step 0 + if posE + then return e + else return (-e) + + (ReadP.satisfy isE >> + ((Scientific signedCoeff . (expnt +)) <$> eP)) `mplus` + return (Scientific signedCoeff expnt) + + +foldDigits :: (a -> Int -> a) -> a -> ReadP a +foldDigits f z = do + c <- ReadP.satisfy isDecimal + let digit = ord c - 48 + a = f z digit + + ReadP.look >>= go a + where + go !a [] = return a + go !a (c:cs) + | isDecimal c = do + _ <- ReadP.get + let digit = ord c - 48 + go (f a digit) cs + | otherwise = return a + +isDecimal :: Char -> Bool +isDecimal c = c >= '0' && c <= '9' +{-# INLINE isDecimal #-} + +isSign :: Char -> Bool +isSign c = c == '-' || c == '+' +{-# INLINE isSign #-} + +isE :: Char -> Bool +isE c = c == 'e' || c == 'E' +{-# INLINE isE #-} + + +---------------------------------------------------------------------- +-- Pretty Printing +---------------------------------------------------------------------- + +-- | See 'formatScientific' if you need more control over the rendering. +instance Show Scientific where + showsPrec d s + | coefficient s < 0 = showParen (d > prefixMinusPrec) $ + showChar '-' . showPositive (-s) + | otherwise = showPositive s + where + prefixMinusPrec :: Int + prefixMinusPrec = 6 + + showPositive :: Scientific -> ShowS + showPositive = showString . fmtAsGeneric . toDecimalDigits + + fmtAsGeneric :: ([Int], Int) -> String + fmtAsGeneric x@(_is, e) + | e < 0 || e > 7 = fmtAsExponent x + | otherwise = fmtAsFixed x + +fmtAsExponent :: ([Int], Int) -> String +fmtAsExponent (is, e) = + case ds of + "0" -> "0.0e0" + [d] -> d : '.' :'0' : 'e' : show_e' + (d:ds') -> d : '.' : ds' ++ ('e' : show_e') + [] -> error "formatScientific/doFmt/FFExponent: []" + where + show_e' = show (e-1) + + ds = map intToDigit is + +fmtAsFixed :: ([Int], Int) -> String +fmtAsFixed (is, e) + | e <= 0 = '0':'.':(replicate (-e) '0' ++ ds) + | otherwise = + let + f 0 s rs = mk0 (reverse s) ++ '.':mk0 rs + f n s "" = f (n-1) ('0':s) "" + f n s (r:rs) = f (n-1) (r:s) rs + in + f e "" ds + where + mk0 "" = "0" + mk0 ls = ls + + ds = map intToDigit is + +-- | Like 'show' but provides rendering options. +formatScientific :: FPFormat + -> Maybe Int -- ^ Number of decimal places to render. + -> Scientific + -> String +formatScientific format mbDecs s + | coefficient s < 0 = '-':formatPositiveScientific (-s) + | otherwise = formatPositiveScientific s + where + formatPositiveScientific :: Scientific -> String + formatPositiveScientific s' = case format of + Generic -> fmtAsGeneric $ toDecimalDigits s' + Exponent -> fmtAsExponentMbDecs $ toDecimalDigits s' + Fixed -> fmtAsFixedMbDecs $ toDecimalDigits s' + + fmtAsGeneric :: ([Int], Int) -> String + fmtAsGeneric x@(_is, e) + | e < 0 || e > 7 = fmtAsExponentMbDecs x + | otherwise = fmtAsFixedMbDecs x + + fmtAsExponentMbDecs :: ([Int], Int) -> String + fmtAsExponentMbDecs x = case mbDecs of + Nothing -> fmtAsExponent x + Just dec -> fmtAsExponentDecs dec x + + fmtAsFixedMbDecs :: ([Int], Int) -> String + fmtAsFixedMbDecs x = case mbDecs of + Nothing -> fmtAsFixed x + Just dec -> fmtAsFixedDecs dec x + + fmtAsExponentDecs :: Int -> ([Int], Int) -> String + fmtAsExponentDecs dec (is, e) = + let dec' = max dec 1 in + case is of + [0] -> '0' :'.' : take dec' (repeat '0') ++ "e0" + _ -> + let (ei,is') = roundTo (dec'+1) is + in case map intToDigit (if ei > 0 then init is' else is') of + [] -> "" + d:ds' -> d:'.':ds' ++ 'e':show (e-1+ei) + + fmtAsFixedDecs :: Int -> ([Int], Int) -> String + fmtAsFixedDecs dec (is, e) = + let dec' = max dec 0 in + if e >= 0 then + let + (ei,is') = roundTo (dec' + e) is + (ls,rs) = splitAt (e+ei) (map intToDigit is') + in + mk0 ls ++ (if null rs then "" else '.':rs) + else + let (ei,is') = roundTo dec' (replicate (-e) 0 ++ is) + in case map intToDigit (if ei > 0 then is' else 0:is') of + [] -> "" + d:ds' -> d : (if null ds' then "" else '.':ds') + where + mk0 ls = case ls of { "" -> "0" ; _ -> ls} + +---------------------------------------------------------------------- + +-- | Similar to 'Numeric.floatToDigits', @toDecimalDigits@ takes a +-- positive 'Scientific' number, and returns a list of digits and +-- a base-10 exponent. In particular, if @x>=0@, and +-- +-- > toDecimalDigits x = ([d1,d2,...,dn], e) +-- +-- then +-- +-- 1. @n >= 1@ +-- 2. @x = 0.d1d2...dn * (10^^e)@ +-- 3. @0 <= di <= 9@ +-- 4. @null $ takeWhile (==0) $ reverse [d1,d2,...,dn]@ +-- +-- The last property means that the coefficient will be normalized, i.e. doesn't +-- contain trailing zeros. +toDecimalDigits :: Scientific -> ([Int], Int) +toDecimalDigits (Scientific 0 _) = ([0], 0) +toDecimalDigits (Scientific c' e') = + case normalizePositive c' e' of + Scientific c e -> go c 0 [] + where + go :: Integer -> Int -> [Int] -> ([Int], Int) + go 0 !n ds = (ds, ne) where !ne = n + e + go i !n ds = case i `quotRemInteger` 10 of + (# q, r #) -> go q (n+1) (d:ds) + where + !d = fromIntegral r + + +---------------------------------------------------------------------- +-- Normalization +---------------------------------------------------------------------- + +-- | Normalize a scientific number by dividing out powers of 10 from the +-- 'coefficient' and incrementing the 'base10Exponent' each time. +-- +-- You should rarely have a need for this function since scientific numbers are +-- automatically normalized when pretty-printed and in 'toDecimalDigits'. +normalize :: Scientific -> Scientific +normalize (Scientific c e) + | c > 0 = normalizePositive c e + | c < 0 = -(normalizePositive (-c) e) + | otherwise {- c == 0 -} = Scientific 0 0 + +normalizePositive :: Integer -> Int -> Scientific +normalizePositive !c !e = case quotRemInteger c 10 of + (# c', r #) + | r == 0 -> normalizePositive c' (e+1) + | otherwise -> Scientific c e diff --git a/bundled/Data/Serialize.hs b/bundled/Data/Serialize.hs new file mode 100644 index 0000000..2a2c7cb --- /dev/null +++ b/bundled/Data/Serialize.hs @@ -0,0 +1,709 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures + , TypeOperators + , BangPatterns + , KindSignatures + , ScopedTypeVariables #-} + +#ifndef MIN_VERSION_base +#define MIN_VERSION_base(x,y,z) 1 +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Serialize +-- Copyright : Lennart Kolmodin, Galois Inc. 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- +----------------------------------------------------------------------------- + +module Data.Serialize ( + + -- * The Serialize class + Serialize(..) + + -- $example + + -- * Serialize serialisation + , encode, encodeLazy + , decode, decodeLazy + + , expect + , module Data.Serialize.Get + , module Data.Serialize.Put + , module Data.Serialize.IEEE754 + + -- * Generic deriving + , GSerializePut(..) + , GSerializeGet(..) + ) where + +import Data.Serialize.Put +import Data.Serialize.Get +import Data.Serialize.IEEE754 + +import Control.Monad +import Data.Array.Unboxed +import Data.ByteString (ByteString) +import Data.Char (chr,ord) +import Data.List (unfoldr) +import Data.Word +import Foreign + +-- And needed for the instances: +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Short as S +import qualified Data.Map as Map +import qualified Data.Monoid as M +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Ratio as R +import qualified Data.Tree as T +import qualified Data.Sequence as Seq + +import GHC.Generics + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative ((*>),(<*>),(<$>),pure) +#endif + +#if MIN_VERSION_base(4,8,0) +import Numeric.Natural +#endif + +------------------------------------------------------------------------ + + +-- | If your compiler has support for the @DeriveGeneric@ and +-- @DefaultSignatures@ language extensions (@ghc >= 7.2.1@), the 'put' and 'get' +-- methods will have default generic implementations. +-- +-- To use this option, simply add a @deriving 'Generic'@ clause to your datatype +-- and declare a 'Serialize' instance for it without giving a definition for +-- 'put' and 'get'. +class Serialize t where + -- | Encode a value in the Put monad. + put :: Putter t + -- | Decode a value in the Get monad + get :: Get t + + default put :: (Generic t, GSerializePut (Rep t)) => Putter t + put = gPut . from + + default get :: (Generic t, GSerializeGet (Rep t)) => Get t + get = to <$> gGet + +------------------------------------------------------------------------ +-- Wrappers to run the underlying monad + +-- | Encode a value using binary serialization to a strict ByteString. +encode :: Serialize a => a -> ByteString +encode = runPut . put + +-- | Encode a value using binary serialization to a lazy ByteString. +encodeLazy :: Serialize a => a -> L.ByteString +encodeLazy = runPutLazy . put + +-- | Decode a value from a strict ByteString, reconstructing the original +-- structure. +decode :: Serialize a => ByteString -> Either String a +decode = runGet get + +-- | Decode a value from a lazy ByteString, reconstructing the original +-- structure. +decodeLazy :: Serialize a => L.ByteString -> Either String a +decodeLazy = runGetLazy get + + +------------------------------------------------------------------------ +-- Combinators + +-- | Perform an action, failing if the read result does not match the argument +-- provided. +expect :: (Eq a, Serialize a) => a -> Get a +expect x = get >>= \y -> if x == y then return x else mzero + + +------------------------------------------------------------------------ +-- Simple instances + +-- The () type need never be written to disk: values of singleton type +-- can be reconstructed from the type alone +instance Serialize () where + put () = return () + get = return () + +{-# INLINE boolToWord8 #-} +boolToWord8 :: Bool -> Word8 +boolToWord8 False = 0 +boolToWord8 True = 1 + +{-# INLINE boolFromWord8 #-} +boolFromWord8 :: Word8 -> Get Bool +boolFromWord8 0 = return False +boolFromWord8 1 = return True +boolFromWord8 w = fail ("Invalid Bool encoding " ++ show w) + +{-# INLINE orderingToWord8 #-} +orderingToWord8 :: Ordering -> Word8 +orderingToWord8 LT = 0 +orderingToWord8 EQ = 1 +orderingToWord8 GT = 2 + +{-# INLINE orderingFromWord8 #-} +orderingFromWord8 :: Word8 -> Get Ordering +orderingFromWord8 0 = return LT +orderingFromWord8 1 = return EQ +orderingFromWord8 2 = return GT +orderingFromWord8 w = fail ("Invalid Ordering encoding " ++ show w) + +-- Bools are encoded as a byte in the range 0 .. 1 +instance Serialize Bool where + put = putWord8 . boolToWord8 + get = boolFromWord8 =<< getWord8 + +-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2 +instance Serialize Ordering where + put = putWord8 . orderingToWord8 + get = orderingFromWord8 =<< getWord8 + +------------------------------------------------------------------------ +-- Words and Ints + +-- Words8s are written as bytes +instance Serialize Word8 where + put = putWord8 + get = getWord8 + +-- Words16s are written as 2 bytes in big-endian (network) order +instance Serialize Word16 where + put = putWord16be + get = getWord16be + +-- Words32s are written as 4 bytes in big-endian (network) order +instance Serialize Word32 where + put = putWord32be + get = getWord32be + +-- Words64s are written as 8 bytes in big-endian (network) order +instance Serialize Word64 where + put = putWord64be + get = getWord64be + +-- Int8s are written as a single byte. +instance Serialize Int8 where + put = putInt8 + get = getInt8 + +-- Int16s are written as a 2 bytes in big endian format +instance Serialize Int16 where + put = putInt16be + get = getInt16be + +-- Int32s are written as a 4 bytes in big endian format +instance Serialize Int32 where + put = putInt32be + get = getInt32be + +-- Int64s are written as a 8 bytes in big endian format +instance Serialize Int64 where + put = putInt64be + get = getInt64be + +------------------------------------------------------------------------ + +-- Words are are written as Word64s, that is, 8 bytes in big endian format +instance Serialize Word where + put i = put (fromIntegral i :: Word64) + get = liftM fromIntegral (get :: Get Word64) + +-- Ints are are written as Int64s, that is, 8 bytes in big endian format +instance Serialize Int where + put i = put (fromIntegral i :: Int64) + get = liftM fromIntegral (get :: Get Int64) + +------------------------------------------------------------------------ +-- +-- Portable, and pretty efficient, serialisation of Integer +-- + +-- Fixed-size type for a subset of Integer +type SmallInt = Int32 + +-- Integers are encoded in two ways: if they fit inside a SmallInt, +-- they're written as a byte tag, and that value. If the Integer value +-- is too large to fit in a SmallInt, it is written as a byte array, +-- along with a sign and length field. + +instance Serialize Integer where + + put n | n >= lo && n <= hi = do + putWord8 0 + put (fromIntegral n :: SmallInt) -- fast path + where + lo = fromIntegral (minBound :: SmallInt) :: Integer + hi = fromIntegral (maxBound :: SmallInt) :: Integer + + put n = do + putWord8 1 + put sign + let len = ((nrBits (abs n) + 7) `div` 8) + putWord64be (fromIntegral len) + mapM_ put (unroll (abs n)) -- unroll the bytes + where + sign = fromIntegral (signum n) :: Word8 + + get = do + tag <- get :: Get Word8 + case tag of + 0 -> liftM fromIntegral (get :: Get SmallInt) + _ -> do sign <- get + bytes <- get + let v = roll bytes + return $! if sign == (1 :: Word8) then v else - v + +-- +-- Fold and unfold an Integer to and from a list of its bytes +-- +unroll :: (Integral a, Bits a) => a -> [Word8] +unroll = unfoldr step + where + step 0 = Nothing + step i = Just (fromIntegral i, i `shiftR` 8) + +roll :: (Integral a, Bits a) => [Word8] -> a +roll = foldr unstep 0 + where + unstep b a = a `shiftL` 8 .|. fromIntegral b + +nrBits :: (Ord a, Integral a) => a -> Int +nrBits k = + let expMax = until (\e -> 2 ^ e > k) (* 2) 1 + findNr :: Int -> Int -> Int + findNr lo hi + | mid == lo = hi + | 2 ^ mid <= k = findNr mid hi + | otherwise = findNr lo mid + where mid = (lo + hi) `div` 2 + in findNr (expMax `div` 2) expMax + +instance (Serialize a,Integral a) => Serialize (R.Ratio a) where + put r = put (R.numerator r) >> put (R.denominator r) + get = liftM2 (R.%) get get + +#if MIN_VERSION_base(4,8,0) +-- Fixed-size type for a subset of Natural +type NaturalWord = Word64 + +instance Serialize Natural where + {-# INLINE put #-} + put n | n <= hi = do + putWord8 0 + put (fromIntegral n :: NaturalWord) -- fast path + where + hi = fromIntegral (maxBound :: NaturalWord) :: Natural + + put n = do + putWord8 1 + let len = ((nrBits (abs n) + 7) `div` 8) + putWord64be (fromIntegral len) + mapM_ put (unroll (abs n)) -- unroll the bytes + + {-# INLINE get #-} + get = do + tag <- get :: Get Word8 + case tag of + 0 -> liftM fromIntegral (get :: Get NaturalWord) + _ -> do bytes <- get + return $! roll bytes +#endif + +------------------------------------------------------------------------ + +-- Safely wrap `chr` to avoid exceptions. +-- `chr` source: http://hackage.haskell.org/package/base-4.7.0.2/docs/src/GHC-Char.html#chr +chrEither :: Int -> Either String Char +chrEither i + | i <= 0x10FFFF = Right (chr i) -- Or: C# (chr# i#) + | otherwise = + Left ("bad argument: " ++ show i) + +-- Char is serialised as UTF-8 +instance Serialize Char where + put a | c <= 0x7f = put (fromIntegral c :: Word8) + | c <= 0x7ff = do put (0xc0 .|. y) + put (0x80 .|. z) + | c <= 0xffff = do put (0xe0 .|. x) + put (0x80 .|. y) + put (0x80 .|. z) + | c <= 0x10ffff = do put (0xf0 .|. w) + put (0x80 .|. x) + put (0x80 .|. y) + put (0x80 .|. z) + | otherwise = error "Not a valid Unicode code point" + where + c = ord a + z, y, x, w :: Word8 + z = fromIntegral (c .&. 0x3f) + y = fromIntegral (shiftR c 6 .&. 0x3f) + x = fromIntegral (shiftR c 12 .&. 0x3f) + w = fromIntegral (shiftR c 18 .&. 0x7) + + get = do + let getByte = liftM (fromIntegral :: Word8 -> Int) get + shiftL6 = flip shiftL 6 :: Int -> Int + w <- getByte + r <- case () of + _ | w < 0x80 -> return w + | w < 0xe0 -> do + x <- liftM (xor 0x80) getByte + return (x .|. shiftL6 (xor 0xc0 w)) + | w < 0xf0 -> do + x <- liftM (xor 0x80) getByte + y <- liftM (xor 0x80) getByte + return (y .|. shiftL6 (x .|. shiftL6 + (xor 0xe0 w))) + | otherwise -> do + x <- liftM (xor 0x80) getByte + y <- liftM (xor 0x80) getByte + z <- liftM (xor 0x80) getByte + return (z .|. shiftL6 (y .|. shiftL6 + (x .|. shiftL6 (xor 0xf0 w)))) + case chrEither r of + Right r' -> + return $! r' + Left err -> + fail err + +------------------------------------------------------------------------ +-- Instances for the first few tuples + +instance (Serialize a, Serialize b) => Serialize (a,b) where + put = putTwoOf put put + get = getTwoOf get get + +instance (Serialize a, Serialize b, Serialize c) => Serialize (a,b,c) where + put (a,b,c) = put a >> put b >> put c + get = liftM3 (,,) get get get + +instance (Serialize a, Serialize b, Serialize c, Serialize d) + => Serialize (a,b,c,d) where + put (a,b,c,d) = put a >> put b >> put c >> put d + get = liftM4 (,,,) get get get get + +instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e) + => Serialize (a,b,c,d,e) where + put (a,b,c,d,e) = put a >> put b >> put c >> put d >> put e + get = liftM5 (,,,,) get get get get get + +-- +-- and now just recurse: +-- + +instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e + , Serialize f) + => Serialize (a,b,c,d,e,f) where + put (a,b,c,d,e,f) = put (a,(b,c,d,e,f)) + get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f) + +instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e + , Serialize f, Serialize g) + => Serialize (a,b,c,d,e,f,g) where + put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g)) + get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g) + +instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e, + Serialize f, Serialize g, Serialize h) + => Serialize (a,b,c,d,e,f,g,h) where + put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h)) + get = do (a,(b,c,d,e,f,g,h)) <- get + return (a,b,c,d,e,f,g,h) + +instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e, + Serialize f, Serialize g, Serialize h, Serialize i) + => Serialize (a,b,c,d,e,f,g,h,i) where + put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i)) + get = do (a,(b,c,d,e,f,g,h,i)) <- get + return (a,b,c,d,e,f,g,h,i) + +instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e, + Serialize f, Serialize g, Serialize h, Serialize i, Serialize j) + => Serialize (a,b,c,d,e,f,g,h,i,j) where + put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j)) + get = do (a,(b,c,d,e,f,g,h,i,j)) <- get + return (a,b,c,d,e,f,g,h,i,j) + +------------------------------------------------------------------------ +-- Monoid newtype wrappers + +instance Serialize a => Serialize (M.Dual a) where + put = put . M.getDual + get = fmap M.Dual get + +instance Serialize M.All where + put = put . M.getAll + get = fmap M.All get + +instance Serialize M.Any where + put = put . M.getAny + get = fmap M.Any get + +instance Serialize a => Serialize (M.Sum a) where + put = put . M.getSum + get = fmap M.Sum get + +instance Serialize a => Serialize (M.Product a) where + put = put . M.getProduct + get = fmap M.Product get + +instance Serialize a => Serialize (M.First a) where + put = put . M.getFirst + get = fmap M.First get + +instance Serialize a => Serialize (M.Last a) where + put = put . M.getLast + get = fmap M.Last get + +------------------------------------------------------------------------ +-- Container types + +instance Serialize a => Serialize [a] where + put = putListOf put + get = getListOf get + +instance (Serialize a) => Serialize (Maybe a) where + put = putMaybeOf put + get = getMaybeOf get + +instance (Serialize a, Serialize b) => Serialize (Either a b) where + put = putEitherOf put put + get = getEitherOf get get + +------------------------------------------------------------------------ +-- ByteStrings (have specially efficient instances) + +instance Serialize B.ByteString where + put bs = do put (B.length bs :: Int) + putByteString bs + get = get >>= getByteString + +instance Serialize L.ByteString where + put bs = do put (L.length bs :: Int64) + putLazyByteString bs + get = get >>= getLazyByteString + +instance Serialize S.ShortByteString where + put sbs = do put (S.length sbs) + putShortByteString sbs + get = get >>= getShortByteString + + +------------------------------------------------------------------------ +-- Maps and Sets + +instance (Ord a, Serialize a) => Serialize (Set.Set a) where + put = putSetOf put + get = getSetOf get + +instance (Ord k, Serialize k, Serialize e) => Serialize (Map.Map k e) where + put = putMapOf put put + get = getMapOf get get + +instance Serialize IntSet.IntSet where + put = putIntSetOf put + get = getIntSetOf get + +instance (Serialize e) => Serialize (IntMap.IntMap e) where + put = putIntMapOf put put + get = getIntMapOf get get + +------------------------------------------------------------------------ +-- Queues and Sequences + +instance (Serialize e) => Serialize (Seq.Seq e) where + put = putSeqOf put + get = getSeqOf get + +------------------------------------------------------------------------ +-- Floating point + +instance Serialize Double where + put = putFloat64be + get = getFloat64be + +instance Serialize Float where + put = putFloat32be + get = getFloat32be + +------------------------------------------------------------------------ +-- Trees + +instance (Serialize e) => Serialize (T.Tree e) where + put = putTreeOf put + get = getTreeOf get + +------------------------------------------------------------------------ +-- Arrays + +instance (Serialize i, Ix i, Serialize e) => Serialize (Array i e) where + put = putIArrayOf put put + get = getIArrayOf get get + +-- +-- The IArray UArray e constraint is non portable. Requires flexible instances +-- +instance (Serialize i, Ix i, Serialize e, IArray UArray e) + => Serialize (UArray i e) where + put = putIArrayOf put put + get = getIArrayOf get get + +------------------------------------------------------------------------ +-- Generic Serialze + +class GSerializePut f where + gPut :: Putter (f a) + +class GSerializeGet f where + gGet :: Get (f a) + +instance GSerializePut a => GSerializePut (M1 i c a) where + gPut = gPut . unM1 + {-# INLINE gPut #-} + +instance GSerializeGet a => GSerializeGet (M1 i c a) where + gGet = M1 <$> gGet + {-# INLINE gGet #-} + +instance Serialize a => GSerializePut (K1 i a) where + gPut = put . unK1 + {-# INLINE gPut #-} + +instance Serialize a => GSerializeGet (K1 i a) where + gGet = K1 <$> get + {-# INLINE gGet #-} + +instance GSerializePut U1 where + gPut _ = pure () + {-# INLINE gPut #-} + +instance GSerializeGet U1 where + gGet = pure U1 + {-# INLINE gGet #-} + +-- | Always fails to serialize +instance GSerializePut V1 where + gPut v = v `seq` error "GSerializePut.V1" + {-# INLINE gPut #-} + +-- | Always fails to deserialize +instance GSerializeGet V1 where + gGet = fail "GSerializeGet.V1" + {-# INLINE gGet #-} + +instance (GSerializePut a, GSerializePut b) => GSerializePut (a :*: b) where + gPut (a :*: b) = gPut a *> gPut b + {-# INLINE gPut #-} + +instance (GSerializeGet a, GSerializeGet b) => GSerializeGet (a :*: b) where + gGet = (:*:) <$> gGet <*> gGet + {-# INLINE gGet #-} + +-- The following GSerialize* instance for sums has support for serializing types +-- with up to 2^64-1 constructors. It will use the minimal number of bytes +-- needed to encode the constructor. For example when a type has 2^8 +-- constructors or less it will use a single byte to encode the constructor. If +-- it has 2^16 constructors or less it will use two bytes, and so on till 2^64-1. + +#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) +#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) +#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) + +instance ( PutSum a, PutSum b + , SumSize a, SumSize b) => GSerializePut (a :+: b) where + gPut | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64) + | otherwise = sizeError "encode" size + where + size = unTagged (sumSize :: Tagged (a :+: b) Word64) + {-# INLINE gPut #-} + +instance ( GetSum a, GetSum b + , SumSize a, SumSize b) => GSerializeGet (a :+: b) where + gGet | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64) + | otherwise = sizeError "decode" size + where + size = unTagged (sumSize :: Tagged (a :+: b) Word64) + {-# INLINE gGet #-} + +sizeError :: Show size => String -> size -> error +sizeError s size = error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors" + +------------------------------------------------------------------------ + +class PutSum f where + putSum :: (Num word, Bits word, Serialize word) => word -> word -> Putter (f a) + +instance (PutSum a, PutSum b) => PutSum (a :+: b) where + putSum !code !size s = case s of + L1 x -> putSum code sizeL x + R1 x -> putSum (code + sizeL) sizeR x + where +#if MIN_VERSION_base(4,5,0) + sizeL = size `unsafeShiftR` 1 +#else + sizeL = size `shiftR` 1 +#endif + sizeR = size - sizeL + {-# INLINE putSum #-} + +instance GSerializePut a => PutSum (C1 c a) where + putSum !code _ x = put code *> gPut x + {-# INLINE putSum #-} + +------------------------------------------------------------------------ + +checkGetSum :: (Ord word, Num word, Bits word, GetSum f) + => word -> word -> Get (f a) +checkGetSum size code | code < size = getSum code size + | otherwise = fail "Unknown encoding for constructor" +{-# INLINE checkGetSum #-} + +class GetSum f where + getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a) + +instance (GetSum a, GetSum b) => GetSum (a :+: b) where + getSum !code !size | code < sizeL = L1 <$> getSum code sizeL + | otherwise = R1 <$> getSum (code - sizeL) sizeR + where +#if MIN_VERSION_base(4,5,0) + sizeL = size `unsafeShiftR` 1 +#else + sizeL = size `shiftR` 1 +#endif + sizeR = size - sizeL + {-# INLINE getSum #-} + +instance GSerializeGet a => GetSum (C1 c a) where + getSum _ _ = gGet + {-# INLINE getSum #-} + +------------------------------------------------------------------------ + +class SumSize f where + sumSize :: Tagged f Word64 + +newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b} + +instance (SumSize a, SumSize b) => SumSize (a :+: b) where + sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + + unTagged (sumSize :: Tagged b Word64) + +instance SumSize (C1 c a) where + sumSize = Tagged 1 diff --git a/bundled/Data/Serialize/Get.hs b/bundled/Data/Serialize/Get.hs new file mode 100644 index 0000000..692eea4 --- /dev/null +++ b/bundled/Data/Serialize/Get.hs @@ -0,0 +1,847 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE BangPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Serialize.Get +-- Copyright : Lennart Kolmodin, Galois Inc. 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- +-- The Get monad. A monad for efficiently building structures from +-- strict ByteStrings +-- +----------------------------------------------------------------------------- + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +module Data.Serialize.Get ( + + -- * The Get type + Get + , runGet + , runGetLazy + , runGetState + , runGetLazyState + + -- ** Incremental interface + , Result(..) + , runGetPartial + , runGetChunk + + -- * Parsing + , ensure + , isolate + , label + , skip + , uncheckedSkip + , lookAhead + , lookAheadM + , lookAheadE + , uncheckedLookAhead + , bytesRead + + -- * Utility + , getBytes + , remaining + , isEmpty + + -- * Parsing particular types + , getWord8 + , getInt8 + + -- ** ByteStrings + , getByteString + , getLazyByteString + , getShortByteString + + -- ** Big-endian reads + , getWord16be + , getWord32be + , getWord64be + , getInt16be + , getInt32be + , getInt64be + + -- ** Little-endian reads + , getWord16le + , getWord32le + , getWord64le + , getInt16le + , getInt32le + , getInt64le + + -- ** Host-endian, unaligned reads + , getWordhost + , getWord16host + , getWord32host + , getWord64host + + -- ** Containers + , getTwoOf + , getListOf + , getIArrayOf + , getTreeOf + , getSeqOf + , getMapOf + , getIntMapOf + , getSetOf + , getIntSetOf + , getMaybeOf + , getEitherOf + , getNested + ) where + +import qualified Control.Applicative as A +import qualified Control.Monad as M +import Control.Monad (unless) +import qualified Control.Monad.Fail as Fail +import Data.Array.IArray (IArray,listArray) +import Data.Ix (Ix) +import Data.List (intercalate) +import Data.Maybe (isNothing,fromMaybe) +import Foreign +import System.IO.Unsafe (unsafeDupablePerformIO) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Short as BS +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Tree as T + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Base +import GHC.Word +#endif + +-- | The result of a parse. +data Result r = Fail String B.ByteString + -- ^ The parse failed. The 'String' is the + -- message describing the error, if any. + | Partial (B.ByteString -> Result r) + -- ^ Supply this continuation with more input so that + -- the parser can resume. To indicate that no more + -- input is available, use an 'B.empty' string. + | Done r B.ByteString + -- ^ The parse succeeded. The 'B.ByteString' is the + -- input that had not yet been consumed (if any) when + -- the parse succeeded. + +instance Show r => Show (Result r) where + show (Fail msg _) = "Fail " ++ show msg + show (Partial _) = "Partial _" + show (Done r bs) = "Done " ++ show r ++ " " ++ show bs + +instance Functor Result where + fmap _ (Fail msg rest) = Fail msg rest + fmap f (Partial k) = Partial (fmap f . k) + fmap f (Done r bs) = Done (f r) bs + +-- | The Get monad is an Exception and State monad. +newtype Get a = Get + { unGet :: forall r. Input -> Buffer -> More + -> Int -> Failure r + -> Success a r -> Result r } + +type Input = B.ByteString +type Buffer = Maybe B.ByteString + +emptyBuffer :: Buffer +emptyBuffer = Just B.empty + +extendBuffer :: Buffer -> B.ByteString -> Buffer +extendBuffer buf chunk = + do bs <- buf + return $! bs `B.append` chunk +{-# INLINE extendBuffer #-} + +append :: Buffer -> Buffer -> Buffer +append l r = B.append `fmap` l A.<*> r +{-# INLINE append #-} + +bufferBytes :: Buffer -> B.ByteString +bufferBytes = fromMaybe B.empty +{-# INLINE bufferBytes #-} + +type Failure r = Input -> Buffer -> More -> [String] -> String -> Result r +type Success a r = Input -> Buffer -> More -> Int -> a -> Result r + +-- | Have we read all available input? +data More + = Complete + | Incomplete (Maybe Int) + deriving (Eq) + +moreLength :: More -> Int +moreLength m = case m of + Complete -> 0 + Incomplete mb -> fromMaybe 0 mb + +instance Functor Get where + fmap p m = Get $ \ s0 b0 m0 w0 kf ks -> + unGet m s0 b0 m0 w0 kf $ \ s1 b1 m1 w1 a -> ks s1 b1 m1 w1 (p a) + +instance A.Applicative Get where + pure a = Get $ \ s0 b0 m0 w _ ks -> ks s0 b0 m0 w a + {-# INLINE pure #-} + + f <*> x = Get $ \ s0 b0 m0 w0 kf ks -> + unGet f s0 b0 m0 w0 kf $ \ s1 b1 m1 w1 g -> + unGet x s1 b1 m1 w1 kf $ \ s2 b2 m2 w2 y -> ks s2 b2 m2 w2 (g y) + {-# INLINE (<*>) #-} + + m *> k = Get $ \ s0 b0 m0 w0 kf ks -> + unGet m s0 b0 m0 w0 kf $ \ s1 b1 m1 w1 _ -> unGet k s1 b1 m1 w1 kf ks + {-# INLINE (*>) #-} + +instance A.Alternative Get where + empty = failDesc "empty" + {-# INLINE empty #-} + + (<|>) = M.mplus + {-# INLINE (<|>) #-} + +-- Definition directly from Control.Monad.State.Strict +instance Monad Get where + return = A.pure + {-# INLINE return #-} + + m >>= g = Get $ \ s0 b0 m0 w0 kf ks -> + unGet m s0 b0 m0 w0 kf $ \ s1 b1 m1 w1 a -> unGet (g a) s1 b1 m1 w1 kf ks + {-# INLINE (>>=) #-} + + (>>) = (A.*>) + {-# INLINE (>>) #-} + +#if !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail + {-# INLINE fail #-} +#endif + +instance Fail.MonadFail Get where + fail = failDesc + {-# INLINE fail #-} + +instance M.MonadPlus Get where + mzero = failDesc "mzero" + {-# INLINE mzero #-} +-- TODO: Test this! + mplus a b = + Get $ \s0 b0 m0 w0 kf ks -> + let ks' s1 b1 = ks s1 (b0 `append` b1) + kf' _ b1 m1 = kf (s0 `B.append` bufferBytes b1) + (b0 `append` b1) m1 + try _ b1 m1 _ _ = unGet b (s0 `B.append` bufferBytes b1) + b1 m1 w0 kf' ks' + in unGet a s0 emptyBuffer m0 w0 try ks' + {-# INLINE mplus #-} + + +------------------------------------------------------------------------ + +formatTrace :: [String] -> String +formatTrace [] = "Empty call stack" +formatTrace ls = "From:\t" ++ intercalate "\n\t" ls ++ "\n" + +get :: Get B.ByteString +get = Get (\s0 b0 m0 w _ k -> k s0 b0 m0 w s0) +{-# INLINE get #-} + +put :: B.ByteString -> Int -> Get () +put s !w = Get (\_ b0 m _ _ k -> k s b0 m w ()) +{-# INLINE put #-} + +label :: String -> Get a -> Get a +label l m = + Get $ \ s0 b0 m0 w0 kf ks -> + let kf' s1 b1 m1 ls = kf s1 b1 m1 (l:ls) + in unGet m s0 b0 m0 w0 kf' ks + +finalK :: Success a a +finalK s _ _ _ a = Done a s + +failK :: Failure a +failK s b _ ls msg = + Fail (unlines [msg, formatTrace ls]) (s `B.append` bufferBytes b) + +-- | Run the Get monad applies a 'get'-based parser on the input ByteString +runGet :: Get a -> B.ByteString -> Either String a +runGet m str = + case unGet m str Nothing Complete 0 failK finalK of + Fail i _ -> Left i + Done a _ -> Right a + Partial{} -> Left "Failed reading: Internal error: unexpected Partial." +{-# INLINE runGet #-} + +-- | Run the get monad on a single chunk, providing an optional length for the +-- remaining, unseen input, with Nothing indicating that it's not clear how much +-- input is left. For example, with a lazy ByteString, the optional length +-- represents the sum of the lengths of all remaining chunks. +runGetChunk :: Get a -> Maybe Int -> B.ByteString -> Result a +runGetChunk m mbLen str = unGet m str Nothing (Incomplete mbLen) 0 failK finalK +{-# INLINE runGetChunk #-} + +-- | Run the Get monad applies a 'get'-based parser on the input ByteString +runGetPartial :: Get a -> B.ByteString -> Result a +runGetPartial m = runGetChunk m Nothing +{-# INLINE runGetPartial #-} + +-- | Run the Get monad applies a 'get'-based parser on the input +-- ByteString, starting at the specified offset. In addition to the result of get +-- it returns the rest of the input. +runGetState :: Get a -> B.ByteString -> Int + -> Either String (a, B.ByteString) +runGetState m str off = case runGetState' m str off of + (Right a,bs) -> Right (a,bs) + (Left i,_) -> Left i +{-# INLINE runGetState #-} + +-- | Run the Get monad applies a 'get'-based parser on the input +-- ByteString, starting at the specified offset. In addition to the result of get +-- it returns the rest of the input, even in the event of a failure. +runGetState' :: Get a -> B.ByteString -> Int + -> (Either String a, B.ByteString) +runGetState' m str off = + case unGet m (B.drop off str) Nothing Complete 0 failK finalK of + Fail i bs -> (Left i,bs) + Done a bs -> (Right a, bs) + Partial{} -> (Left "Failed reading: Internal error: unexpected Partial.",B.empty) +{-# INLINE runGetState' #-} + + + +-- Lazy Get -------------------------------------------------------------------- + +runGetLazy' :: Get a -> L.ByteString -> (Either String a,L.ByteString) +runGetLazy' m lstr = + case L.toChunks lstr of + [c] -> wrapStrict (runGetState' m c 0) + [] -> wrapStrict (runGetState' m B.empty 0) + c:cs -> loop (runGetChunk m (Just (len - B.length c)) c) cs + where + len = fromIntegral (L.length lstr) + + wrapStrict (e,s) = (e,L.fromChunks [s]) + + loop result chunks = case result of + + Fail str rest -> (Left str, L.fromChunks (rest : chunks)) + Partial k -> case chunks of + c:cs -> loop (k c) cs + [] -> loop (k B.empty) [] + + Done r rest -> (Right r, L.fromChunks (rest : chunks)) +{-# INLINE runGetLazy' #-} + +-- | Run the Get monad over a Lazy ByteString. Note that this will not run the +-- Get parser lazily, but will operate on lazy ByteStrings. +runGetLazy :: Get a -> L.ByteString -> Either String a +runGetLazy m lstr = fst (runGetLazy' m lstr) +{-# INLINE runGetLazy #-} + +-- | Run the Get monad over a Lazy ByteString. Note that this does not run the +-- Get parser lazily, but will operate on lazy ByteStrings. +runGetLazyState :: Get a -> L.ByteString -> Either String (a,L.ByteString) +runGetLazyState m lstr = case runGetLazy' m lstr of + (Right a,rest) -> Right (a,rest) + (Left err,_) -> Left err +{-# INLINE runGetLazyState #-} + +------------------------------------------------------------------------ + +-- | If at least @n@ bytes of input are available, return the current +-- input, otherwise fail. +{-# INLINE ensure #-} +ensure :: Int -> Get B.ByteString +ensure n0 = n0 `seq` Get $ \ s0 b0 m0 w0 kf ks -> let + n' = n0 - B.length s0 + in if n' <= 0 + then ks s0 b0 m0 w0 s0 + else getMore n' s0 [] b0 m0 w0 kf ks + where + -- The "accumulate and concat" pattern here is important not to incur + -- in quadratic behavior, see + + finalInput s0 ss = B.concat (reverse (s0 : ss)) + finalBuffer b0 s0 ss = extendBuffer b0 (B.concat (reverse (init (s0 : ss)))) + getMore !n s0 ss b0 m0 w0 kf ks = let + tooFewBytes = let + !s = finalInput s0 ss + !b = finalBuffer b0 s0 ss + in kf s b m0 ["demandInput"] "too few bytes" + in case m0 of + Complete -> tooFewBytes + Incomplete mb -> Partial $ \s -> + if B.null s + then tooFewBytes + else let + !mb' = case mb of + Just l -> Just $! l - B.length s + Nothing -> Nothing + in checkIfEnough n s (s0 : ss) b0 (Incomplete mb') w0 kf ks + + checkIfEnough !n s0 ss b0 m0 w0 kf ks = let + n' = n - B.length s0 + in if n' <= 0 + then let + !s = finalInput s0 ss + !b = finalBuffer b0 s0 ss + in ks s b m0 w0 s + else getMore n' s0 ss b0 m0 w0 kf ks + +-- | Isolate an action to operating within a fixed block of bytes. The action +-- is required to consume all the bytes that it is isolated to. +isolate :: Int -> Get a -> Get a +isolate n m = do + M.when (n < 0) (fail "Attempted to isolate a negative number of bytes") + s <- ensure n + let (s',rest) = B.splitAt n s + cur <- bytesRead + put s' cur + a <- m + used <- get + unless (B.null used) (fail "not all bytes parsed in isolate") + put rest (cur + n) + return a + +failDesc :: String -> Get a +failDesc err = do + let msg = "Failed reading: " ++ err + Get (\s0 b0 m0 _ kf _ -> kf s0 b0 m0 [] msg) + +-- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. +skip :: Int -> Get () +skip n = do + s <- ensure n + cur <- bytesRead + put (B.drop n s) (cur + n) + +-- | Skip ahead up to @n@ bytes in the current chunk. No error if there aren't +-- enough bytes, or if less than @n@ bytes are skipped. +uncheckedSkip :: Int -> Get () +uncheckedSkip n = do + s <- get + cur <- bytesRead + put (B.drop n s) (cur + n) + +-- | Run @ga@, but return without consuming its input. +-- Fails if @ga@ fails. +lookAhead :: Get a -> Get a +lookAhead ga = Get $ \ s0 b0 m0 w0 kf ks -> + -- the new continuation extends the old input with the new buffered bytes, and + -- appends the new buffer to the old one, if there was one. + let ks' _ b1 = ks (s0 `B.append` bufferBytes b1) (b0 `append` b1) + kf' _ b1 = kf s0 (b0 `append` b1) + in unGet ga s0 emptyBuffer m0 w0 kf' ks' + +-- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'. +-- Fails if @gma@ fails. +lookAheadM :: Get (Maybe a) -> Get (Maybe a) +lookAheadM gma = do + s <- get + pre <- bytesRead + ma <- gma + M.when (isNothing ma) (put s pre) + return ma + +-- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'. +-- Fails if @gea@ fails. +lookAheadE :: Get (Either a b) -> Get (Either a b) +lookAheadE gea = do + s <- get + pre <- bytesRead + ea <- gea + case ea of + Left _ -> put s pre + _ -> return () + return ea + +-- | Get the next up to @n@ bytes as a ByteString until end of this chunk, +-- without consuming them. +uncheckedLookAhead :: Int -> Get B.ByteString +uncheckedLookAhead n = do + s <- get + return (B.take n s) + +------------------------------------------------------------------------ +-- Utility + +-- | Get the number of remaining unparsed bytes. Useful for checking whether +-- all input has been consumed. +-- +-- WARNING: when run with @runGetPartial@, remaining will only return the number +-- of bytes that are remaining in the current input. +remaining :: Get Int +remaining = Get (\ s0 b0 m0 w0 _ ks -> ks s0 b0 m0 w0 (B.length s0 + moreLength m0)) + +-- | Test whether all input has been consumed. +-- +-- WARNING: when run with @runGetPartial@, isEmpty will only tell you if you're +-- at the end of the current chunk. +isEmpty :: Get Bool +isEmpty = Get (\ s0 b0 m0 w0 _ ks -> ks s0 b0 m0 w0 (B.null s0 && moreLength m0 == 0)) + +------------------------------------------------------------------------ +-- Utility with ByteStrings + +-- | An efficient 'get' method for strict ByteStrings. Fails if fewer +-- than @n@ bytes are left in the input. This function creates a fresh +-- copy of the underlying bytes. +getByteString :: Int -> Get B.ByteString +getByteString n = do + bs <- getBytes n + return $! B.copy bs + +getLazyByteString :: Int64 -> Get L.ByteString +getLazyByteString n = f `fmap` getByteString (fromIntegral n) + where f bs = L.fromChunks [bs] + +getShortByteString :: Int -> Get BS.ShortByteString +getShortByteString n = do + bs <- getBytes n + return $! BS.toShort bs + + +------------------------------------------------------------------------ +-- Helpers + +-- | Pull @n@ bytes from the input, as a strict ByteString. +getBytes :: Int -> Get B.ByteString +getBytes n | n < 0 = fail "getBytes: negative length requested" +getBytes n = do + s <- ensure n + let consume = B.unsafeTake n s + rest = B.unsafeDrop n s + -- (consume,rest) = B.splitAt n s + cur <- bytesRead + put rest (cur + n) + return consume +{-# INLINE getBytes #-} + + + +------------------------------------------------------------------------ +-- Primtives + +-- helper, get a raw Ptr onto a strict ByteString copied out of the +-- underlying strict byteString. + +getPtr :: Storable a => Int -> Get a +getPtr n = do + (fp,o,_) <- B.toForeignPtr `fmap` getBytes n + let k p = peek (castPtr (p `plusPtr` o)) + return (unsafeDupablePerformIO (withForeignPtr fp k)) +{-# INLINE getPtr #-} + +----------------------------------------------------------------------- + +-- | Read a Int8 from the monad state +getInt8 :: Get Int8 +getInt8 = do + s <- getBytes 1 + return $! fromIntegral (B.unsafeHead s) + +-- | Read a Int16 in big endian format +getInt16be :: Get Int16 +getInt16be = do + s <- getBytes 2 + return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftL` 8) .|. + (fromIntegral (s `B.unsafeIndex` 1) ) + +-- | Read a Int16 in little endian format +getInt16le :: Get Int16 +getInt16le = do + s <- getBytes 2 + return $! (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) + +-- | Read a Int32 in big endian format +getInt32be :: Get Int32 +getInt32be = do + s <- getBytes 4 + return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftL` 24) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 16) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftL` 8) .|. + (fromIntegral (s `B.unsafeIndex` 3) ) + +-- | Read a Int32 in little endian format +getInt32le :: Get Int32 +getInt32le = do + s <- getBytes 4 + return $! (fromIntegral (s `B.unsafeIndex` 3) `shiftL` 24) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftL` 16) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) + +-- | Read a Int64 in big endian format +getInt64be :: Get Int64 +getInt64be = do + s <- getBytes 8 + return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftL` 56) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 48) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftL` 40) .|. + (fromIntegral (s `B.unsafeIndex` 3) `shiftL` 32) .|. + (fromIntegral (s `B.unsafeIndex` 4) `shiftL` 24) .|. + (fromIntegral (s `B.unsafeIndex` 5) `shiftL` 16) .|. + (fromIntegral (s `B.unsafeIndex` 6) `shiftL` 8) .|. + (fromIntegral (s `B.unsafeIndex` 7) ) + +-- | Read a Int64 in little endian format +getInt64le :: Get Int64 +getInt64le = do + s <- getBytes 8 + return $! (fromIntegral (s `B.unsafeIndex` 7) `shiftL` 56) .|. + (fromIntegral (s `B.unsafeIndex` 6) `shiftL` 48) .|. + (fromIntegral (s `B.unsafeIndex` 5) `shiftL` 40) .|. + (fromIntegral (s `B.unsafeIndex` 4) `shiftL` 32) .|. + (fromIntegral (s `B.unsafeIndex` 3) `shiftL` 24) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftL` 16) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) + +{-# INLINE getInt8 #-} +{-# INLINE getInt16be #-} +{-# INLINE getInt16le #-} +{-# INLINE getInt32be #-} +{-# INLINE getInt32le #-} +{-# INLINE getInt64be #-} +{-# INLINE getInt64le #-} + +------------------------------------------------------------------------ + +-- | Read a Word8 from the monad state +getWord8 :: Get Word8 +getWord8 = do + s <- getBytes 1 + return (B.unsafeHead s) + +-- | Read a Word16 in big endian format +getWord16be :: Get Word16 +getWord16be = do + s <- getBytes 2 + return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w16` 8) .|. + (fromIntegral (s `B.unsafeIndex` 1)) + +-- | Read a Word16 in little endian format +getWord16le :: Get Word16 +getWord16le = do + s <- getBytes 2 + return $! (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w16` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) + +-- | Read a Word32 in big endian format +getWord32be :: Get Word32 +getWord32be = do + s <- getBytes 4 + return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w32` 24) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 16) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 8) .|. + (fromIntegral (s `B.unsafeIndex` 3) ) + +-- | Read a Word32 in little endian format +getWord32le :: Get Word32 +getWord32le = do + s <- getBytes 4 + return $! (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w32` 24) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 16) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) + +-- | Read a Word64 in big endian format +getWord64be :: Get Word64 +getWord64be = do + s <- getBytes 8 + return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w64` 56) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 48) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 40) .|. + (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 32) .|. + (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 24) .|. + (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 16) .|. + (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 8) .|. + (fromIntegral (s `B.unsafeIndex` 7) ) + +-- | Read a Word64 in little endian format +getWord64le :: Get Word64 +getWord64le = do + s <- getBytes 8 + return $! (fromIntegral (s `B.unsafeIndex` 7) `shiftl_w64` 56) .|. + (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 48) .|. + (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 40) .|. + (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 32) .|. + (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 24) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 16) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) + +{-# INLINE getWord8 #-} +{-# INLINE getWord16be #-} +{-# INLINE getWord16le #-} +{-# INLINE getWord32be #-} +{-# INLINE getWord32le #-} +{-# INLINE getWord64be #-} +{-# INLINE getWord64le #-} + +------------------------------------------------------------------------ +-- Host-endian reads + +-- | /O(1)./ Read a single native machine word. The word is read in +-- host order, host endian form, for the machine you're on. On a 64 bit +-- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes. +getWordhost :: Get Word +getWordhost = getPtr (sizeOf (undefined :: Word)) + +-- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness. +getWord16host :: Get Word16 +getWord16host = getPtr (sizeOf (undefined :: Word16)) + +-- | /O(1)./ Read a Word32 in native host order and host endianness. +getWord32host :: Get Word32 +getWord32host = getPtr (sizeOf (undefined :: Word32)) + +-- | /O(1)./ Read a Word64 in native host order and host endianness. +getWord64host :: Get Word64 +getWord64host = getPtr (sizeOf (undefined :: Word64)) + +------------------------------------------------------------------------ +-- Unchecked shifts + +shiftl_w16 :: Word16 -> Int -> Word16 +shiftl_w32 :: Word32 -> Int -> Word32 +shiftl_w64 :: Word64 -> Int -> Word64 + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#if MIN_VERSION_base(4,16,0) +shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftLWord16#` i) +shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftLWord32#` i) +#else +shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) +shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i) +#endif + +#if WORD_SIZE_IN_BITS < 64 +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i) + +#if __GLASGOW_HASKELL__ <= 606 +-- Exported by GHC.Word in GHC 6.8 and higher +foreign import ccall unsafe "stg_uncheckedShiftL64" + uncheckedShiftL64# :: Word64# -> Int# -> Word64# +#endif + +#else +#if MIN_VERSION_base(4,17,0) +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i) +#else +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) +#endif +#endif + +#else +shiftl_w16 = shiftL +shiftl_w32 = shiftL +shiftl_w64 = shiftL +#endif + + +-- Containers ------------------------------------------------------------------ + +getTwoOf :: Get a -> Get b -> Get (a,b) +getTwoOf ma mb = M.liftM2 (,) ma mb + +-- | Get a list in the following format: +-- Word64 (big endian format) +-- element 1 +-- ... +-- element n +getListOf :: Get a -> Get [a] +getListOf m = go [] =<< getWord64be + where + go as 0 = return $! reverse as + go as i = do x <- m + x `seq` go (x:as) (i - 1) + +-- | Get an IArray in the following format: +-- index (lower bound) +-- index (upper bound) +-- Word64 (big endian format) +-- element 1 +-- ... +-- element n +getIArrayOf :: (Ix i, IArray a e) => Get i -> Get e -> Get (a i e) +getIArrayOf ix e = M.liftM2 listArray (getTwoOf ix ix) (getListOf e) + +-- | Get a sequence in the following format: +-- Word64 (big endian format) +-- element 1 +-- ... +-- element n +getSeqOf :: Get a -> Get (Seq.Seq a) +getSeqOf m = go Seq.empty =<< getWord64be + where + go xs 0 = return $! xs + go xs n = xs `seq` n `seq` do + x <- m + go (xs Seq.|> x) (n - 1) + +-- | Read as a list of lists. +getTreeOf :: Get a -> Get (T.Tree a) +getTreeOf m = M.liftM2 T.Node m (getListOf (getTreeOf m)) + +-- | Read as a list of pairs of key and element. +getMapOf :: Ord k => Get k -> Get a -> Get (Map.Map k a) +getMapOf k m = Map.fromList `fmap` getListOf (getTwoOf k m) + +-- | Read as a list of pairs of int and element. +getIntMapOf :: Get Int -> Get a -> Get (IntMap.IntMap a) +getIntMapOf i m = IntMap.fromList `fmap` getListOf (getTwoOf i m) + +-- | Read as a list of elements. +getSetOf :: Ord a => Get a -> Get (Set.Set a) +getSetOf m = Set.fromList `fmap` getListOf m + +-- | Read as a list of ints. +getIntSetOf :: Get Int -> Get IntSet.IntSet +getIntSetOf m = IntSet.fromList `fmap` getListOf m + +-- | Read in a Maybe in the following format: +-- Word8 (0 for Nothing, anything else for Just) +-- element (when Just) +getMaybeOf :: Get a -> Get (Maybe a) +getMaybeOf m = do + tag <- getWord8 + case tag of + 0 -> return Nothing + _ -> Just `fmap` m + +-- | Read an Either, in the following format: +-- Word8 (0 for Left, anything else for Right) +-- element a when 0, element b otherwise +getEitherOf :: Get a -> Get b -> Get (Either a b) +getEitherOf ma mb = do + tag <- getWord8 + case tag of + 0 -> Left `fmap` ma + _ -> Right `fmap` mb + +-- | Read in a length and then read a nested structure +-- of that length. +getNested :: Get Int -> Get a -> Get a +getNested getLen getVal = do + n <- getLen + isolate n getVal + +-- | Get the number of bytes read up to this point +bytesRead :: Get Int +bytesRead = Get (\i b m w _ k -> k i b m w w) diff --git a/bundled/Data/Serialize/IEEE754.hs b/bundled/Data/Serialize/IEEE754.hs new file mode 100644 index 0000000..18ba67d --- /dev/null +++ b/bundled/Data/Serialize/IEEE754.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +#ifndef MIN_VERSION_base +#define MIN_VERSION_base(x,y,z) 1 +#endif + +-- | IEEE-754 parsing, as described in this stack-overflow article: +-- +-- + +module Data.Serialize.IEEE754 ( + + -- * IEEE-754 reads + getFloat32le + , getFloat32be + , getFloat64le + , getFloat64be + + -- * IEEE-754 writes + , putFloat32le + , putFloat32be + , putFloat64le + , putFloat64be + +) where + +import Data.Word ( Word32, Word64 ) +import Data.Serialize.Get +import Data.Serialize.Put +import qualified Data.ByteString.Builder as Builder +import System.IO.Unsafe (unsafeDupablePerformIO) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Storable (peek, poke) +import Foreign.Ptr (castPtr, Ptr) + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative ( (<$>) ) +#endif + +-- | Read a Float in little endian IEEE-754 format +getFloat32le :: Get Float +getFloat32le = wordToFloat <$> getWord32le + +-- | Read a Float in big endian IEEE-754 format +getFloat32be :: Get Float +getFloat32be = wordToFloat <$> getWord32be + +-- | Read a Double in little endian IEEE-754 format +getFloat64le :: Get Double +getFloat64le = wordToDouble <$> getWord64le + +-- | Read a Double in big endian IEEE-754 format +getFloat64be :: Get Double +getFloat64be = wordToDouble <$> getWord64be + +-- | Write a Float in little endian IEEE-754 format +putFloat32le :: Float -> Put +putFloat32le = putBuilder . Builder.floatLE + +-- | Write a Float in big endian IEEE-754 format +putFloat32be :: Float -> Put +putFloat32be = putBuilder . Builder.floatBE + +-- | Write a Double in little endian IEEE-754 format +putFloat64le :: Double -> Put +putFloat64le = putBuilder . Builder.doubleLE + +-- | Write a Double in big endian IEEE-754 format +putFloat64be :: Double -> Put +putFloat64be = putBuilder . Builder.doubleBE + +{-# INLINE wordToFloat #-} +wordToFloat :: Word32 -> Float +wordToFloat w = unsafeDupablePerformIO $ alloca $ \(ptr :: Ptr Word32) -> do + poke ptr w + peek (castPtr ptr) + +{-# INLINE wordToDouble #-} +wordToDouble :: Word64 -> Double +wordToDouble w = unsafeDupablePerformIO $ alloca $ \(ptr :: Ptr Word64) -> do + poke ptr w + peek (castPtr ptr) diff --git a/bundled/Data/Serialize/Put.hs b/bundled/Data/Serialize/Put.hs new file mode 100644 index 0000000..305ad89 --- /dev/null +++ b/bundled/Data/Serialize/Put.hs @@ -0,0 +1,484 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} + +#ifndef MIN_VERSION_base +#define MIN_VERSION_base(x,y,z) 0 +#endif + +#ifndef MIN_VERSION_bytestring +#define MIN_VERSION_bytestring(x,y,z) 0 +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Serialize.Put +-- Copyright : Lennart Kolmodin, Galois Inc. 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- +-- The Put monad. A monad for efficiently constructing bytestrings. +-- +----------------------------------------------------------------------------- + +module Data.Serialize.Put ( + + -- * The Put type + Put + , PutM(..) + , Putter + , runPut + , runPutM + , runPutLazy + , runPutMLazy + , runPutMBuilder + , putBuilder + , execPut + + -- * Flushing the implicit parse state + , flush + + -- * Primitives + , putWord8 + , putInt8 + , putByteString + , putLazyByteString + , putShortByteString + + -- * Big-endian primitives + , putWord16be + , putWord32be + , putWord64be + , putInt16be + , putInt32be + , putInt64be + + -- * Little-endian primitives + , putWord16le + , putWord32le + , putWord64le + , putInt16le + , putInt32le + , putInt64le + + -- * Host-endian, unaligned writes + , putWordhost + , putWord16host + , putWord32host + , putWord64host + , putInthost + , putInt16host + , putInt32host + , putInt64host + + -- * Containers + , putTwoOf + , putListOf + , putIArrayOf + , putSeqOf + , putTreeOf + , putMapOf + , putIntMapOf + , putSetOf + , putIntSetOf + , putMaybeOf + , putEitherOf + , putNested + + ) where + + +import Data.ByteString.Builder (Builder, toLazyByteString) +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Extra as B +import qualified Data.ByteString.Short as BS + +import qualified Control.Applicative as A +import Data.Array.Unboxed +#if MIN_VERSION_base(4,9,0) +import qualified Data.Semigroup as M +#endif +import qualified Data.Monoid as M +import qualified Data.Foldable as F +import Data.Word +import Data.Int +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Tree as T + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative +import Data.Foldable (foldMap) +import Data.Monoid +#endif + +#if !(MIN_VERSION_bytestring(0,10,0)) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Marshal.Utils (copyBytes) +import Foreign.Ptr (plusPtr) +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L +#endif + +------------------------------------------------------------------------ + +-- XXX Strict in builder only. +data PairS a = PairS a !Builder + +sndS :: PairS a -> Builder +sndS (PairS _ b) = b + +-- | The PutM type. A Writer monad over the efficient Builder monoid. +newtype PutM a = Put { unPut :: PairS a } + +-- | Put merely lifts Builder into a Writer monad, applied to (). +type Put = PutM () + +type Putter a = a -> Put + +instance Functor PutM where + fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w + {-# INLINE fmap #-} + + +instance A.Applicative PutM where + pure a = Put (PairS a M.mempty) + {-# INLINE pure #-} + + m <*> k = Put $ + let PairS f w = unPut m + PairS x w' = unPut k + in PairS (f x) (w `M.mappend` w') + {-# INLINE (<*>) #-} + + m *> k = Put $ + let PairS _ w = unPut m + PairS b w' = unPut k + in PairS b (w `M.mappend` w') + {-# INLINE (*>) #-} + + +instance Monad PutM where + return = pure + {-# INLINE return #-} + + m >>= k = Put $ + let PairS a w = unPut m + PairS b w' = unPut (k a) + in PairS b (w `M.mappend` w') + {-# INLINE (>>=) #-} + + (>>) = (*>) + {-# INLINE (>>) #-} + +#if MIN_VERSION_base(4,9,0) +instance M.Semigroup (PutM ()) where + (<>) = (*>) + {-# INLINE (<>) #-} +#endif + +instance Monoid (PutM ()) where + mempty = pure () + {-# INLINE mempty #-} + +#if !(MIN_VERSION_base(4,11,0)) + mappend = (*>) + {-# INLINE mappend #-} +#endif + +tell :: Putter Builder +tell b = Put $! PairS () b +{-# INLINE tell #-} + +putBuilder :: Putter Builder +putBuilder = tell +{-# INLINE putBuilder #-} + +-- | Run the 'Put' monad +execPut :: PutM a -> Builder +execPut = sndS . unPut +{-# INLINE execPut #-} + +-- | Run the 'Put' monad with a serialiser +runPut :: Put -> S.ByteString +runPut = lazyToStrictByteString . runPutLazy +{-# INLINE runPut #-} + +-- | Run the 'Put' monad with a serialiser and get its result +runPutM :: PutM a -> (a, S.ByteString) +runPutM (Put (PairS f s)) = (f, lazyToStrictByteString (toLazyByteString s)) +{-# INLINE runPutM #-} + +-- | Run the 'Put' monad with a serialiser +runPutLazy :: Put -> L.ByteString +runPutLazy = toLazyByteString . sndS . unPut +{-# INLINE runPutLazy #-} + +-- | Run the 'Put' monad with a serialiser +runPutMLazy :: PutM a -> (a, L.ByteString) +runPutMLazy (Put (PairS f s)) = (f, toLazyByteString s) +{-# INLINE runPutMLazy #-} + +-- | Run the 'Put' monad and get the result and underlying 'Builder' +runPutMBuilder :: PutM a -> (a, Builder) +runPutMBuilder (Put (PairS f s)) = (f, s) +{-# INLINE runPutMBuilder #-} + +------------------------------------------------------------------------ + +-- | Pop the ByteString we have constructed so far, if any, yielding a +-- new chunk in the result ByteString. +flush :: Put +flush = tell B.flush +{-# INLINE flush #-} + +-- | Efficiently write a byte into the output buffer +putWord8 :: Putter Word8 +putWord8 = tell . B.word8 +{-# INLINE putWord8 #-} + +-- | Efficiently write an int into the output buffer +putInt8 :: Putter Int8 +putInt8 = tell . B.int8 +{-# INLINE putInt8 #-} + +-- | An efficient primitive to write a strict ByteString into the output buffer. +-- It flushes the current buffer, and writes the argument into a new chunk. +putByteString :: Putter S.ByteString +putByteString = tell . B.byteString +{-# INLINE putByteString #-} + +putShortByteString :: Putter BS.ShortByteString +putShortByteString = tell . B.shortByteString + +-- | Write a lazy ByteString efficiently, simply appending the lazy +-- ByteString chunks to the output buffer +putLazyByteString :: Putter L.ByteString +putLazyByteString = tell . B.lazyByteString +{-# INLINE putLazyByteString #-} + +-- | Write a Word16 in big endian format +putWord16be :: Putter Word16 +putWord16be = tell . B.word16BE +{-# INLINE putWord16be #-} + +-- | Write a Word16 in little endian format +putWord16le :: Putter Word16 +putWord16le = tell . B.word16LE +{-# INLINE putWord16le #-} + +-- | Write a Word32 in big endian format +putWord32be :: Putter Word32 +putWord32be = tell . B.word32BE +{-# INLINE putWord32be #-} + +-- | Write a Word32 in little endian format +putWord32le :: Putter Word32 +putWord32le = tell . B.word32LE +{-# INLINE putWord32le #-} + +-- | Write a Word64 in big endian format +putWord64be :: Putter Word64 +putWord64be = tell . B.word64BE +{-# INLINE putWord64be #-} + +-- | Write a Word64 in little endian format +putWord64le :: Putter Word64 +putWord64le = tell . B.word64LE +{-# INLINE putWord64le #-} + +------------------------------------------------------------------------ + +-- | /O(1)./ Write a single native machine word. The word is +-- written in host order, host endian form, for the machine you're on. +-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine, +-- 4 bytes. Values written this way are not portable to +-- different endian or word sized machines, without conversion. +-- +putWordhost :: Putter Word +putWordhost = tell . B.wordHost +{-# INLINE putWordhost #-} + +-- | /O(1)./ Write a Word16 in native host order and host endianness. +-- For portability issues see @putWordhost@. +putWord16host :: Putter Word16 +putWord16host = tell . B.word16Host +{-# INLINE putWord16host #-} + +-- | /O(1)./ Write a Word32 in native host order and host endianness. +-- For portability issues see @putWordhost@. +putWord32host :: Putter Word32 +putWord32host = tell . B.word32Host +{-# INLINE putWord32host #-} + +-- | /O(1)./ Write a Word64 in native host order +-- On a 32 bit machine we write two host order Word32s, in big endian form. +-- For portability issues see @putWordhost@. +putWord64host :: Putter Word64 +putWord64host = tell . B.word64Host +{-# INLINE putWord64host #-} + +-- | Write a Int16 in big endian format +putInt16be :: Putter Int16 +putInt16be = tell . B.int16BE +{-# INLINE putInt16be #-} + +-- | Write a Int16 in little endian format +putInt16le :: Putter Int16 +putInt16le = tell . B.int16LE +{-# INLINE putInt16le #-} + +-- | Write a Int32 in big endian format +putInt32be :: Putter Int32 +putInt32be = tell . B.int32BE +{-# INLINE putInt32be #-} + +-- | Write a Int32 in little endian format +putInt32le :: Putter Int32 +putInt32le = tell . B.int32LE +{-# INLINE putInt32le #-} + +-- | Write a Int64 in big endian format +putInt64be :: Putter Int64 +putInt64be = tell . B.int64BE +{-# INLINE putInt64be #-} + +-- | Write a Int64 in little endian format +putInt64le :: Putter Int64 +putInt64le = tell . B.int64LE +{-# INLINE putInt64le #-} + +------------------------------------------------------------------------ + +-- | /O(1)./ Write a single native machine int. The int is +-- written in host order, host endian form, for the machine you're on. +-- On a 64 bit machine the Int is an 8 byte value, on a 32 bit machine, +-- 4 bytes. Values written this way are not portable to +-- different endian or int sized machines, without conversion. +-- +putInthost :: Putter Int +putInthost = tell . B.intHost +{-# INLINE putInthost #-} + +-- | /O(1)./ Write a Int16 in native host order and host endianness. +-- For portability issues see @putInthost@. +putInt16host :: Putter Int16 +putInt16host = tell . B.int16Host +{-# INLINE putInt16host #-} + +-- | /O(1)./ Write a Int32 in native host order and host endianness. +-- For portability issues see @putInthost@. +putInt32host :: Putter Int32 +putInt32host = tell . B.int32Host +{-# INLINE putInt32host #-} + +-- | /O(1)./ Write a Int64 in native host order +-- On a 32 bit machine we write two host order Int32s, in big endian form. +-- For portability issues see @putInthost@. +putInt64host :: Putter Int64 +putInt64host = tell . B.int64Host +{-# INLINE putInt64host #-} + + +-- Containers ------------------------------------------------------------------ + +encodeListOf :: (a -> Builder) -> [a] -> Builder +encodeListOf f = -- allow inlining with just a single argument + \xs -> execPut (putWord64be (fromIntegral $ length xs)) `M.mappend` + F.foldMap f xs +{-# INLINE encodeListOf #-} + +putTwoOf :: Putter a -> Putter b -> Putter (a,b) +putTwoOf pa pb (a,b) = pa a >> pb b +{-# INLINE putTwoOf #-} + +putListOf :: Putter a -> Putter [a] +putListOf pa = \l -> do + putWord64be (fromIntegral (length l)) + mapM_ pa l +{-# INLINE putListOf #-} + +putIArrayOf :: (Ix i, IArray a e) => Putter i -> Putter e -> Putter (a i e) +putIArrayOf pix pe a = do + putTwoOf pix pix (bounds a) + putListOf pe (elems a) +{-# INLINE putIArrayOf #-} + +putSeqOf :: Putter a -> Putter (Seq.Seq a) +putSeqOf pa = \s -> do + putWord64be (fromIntegral $ Seq.length s) + F.mapM_ pa s +{-# INLINE putSeqOf #-} + +putTreeOf :: Putter a -> Putter (T.Tree a) +putTreeOf pa = + tell . go + where + go (T.Node x cs) = execPut (pa x) `M.mappend` encodeListOf go cs +{-# INLINE putTreeOf #-} + +putMapOf :: Putter k -> Putter a -> Putter (Map.Map k a) +putMapOf pk pa = putListOf (putTwoOf pk pa) . Map.toAscList +{-# INLINE putMapOf #-} + +putIntMapOf :: Putter Int -> Putter a -> Putter (IntMap.IntMap a) +putIntMapOf pix pa = putListOf (putTwoOf pix pa) . IntMap.toAscList +{-# INLINE putIntMapOf #-} + +putSetOf :: Putter a -> Putter (Set.Set a) +putSetOf pa = putListOf pa . Set.toAscList +{-# INLINE putSetOf #-} + +putIntSetOf :: Putter Int -> Putter IntSet.IntSet +putIntSetOf pix = putListOf pix . IntSet.toAscList +{-# INLINE putIntSetOf #-} + +putMaybeOf :: Putter a -> Putter (Maybe a) +putMaybeOf _ Nothing = putWord8 0 +putMaybeOf pa (Just a) = putWord8 1 >> pa a +{-# INLINE putMaybeOf #-} + +putEitherOf :: Putter a -> Putter b -> Putter (Either a b) +putEitherOf pa _ (Left a) = putWord8 0 >> pa a +putEitherOf _ pb (Right b) = putWord8 1 >> pb b +{-# INLINE putEitherOf #-} + +-- | Put a nested structure by first putting a length +-- field and then putting the encoded value. +putNested :: Putter Int -> Put -> Put +putNested putLen putVal = do + let bs = runPut putVal + putLen (S.length bs) + putByteString bs + +------------------------------------------------------------------------------- +-- pre-bytestring-0.10 compatibility +------------------------------------------------------------------------------- + +{-# INLINE lazyToStrictByteString #-} +lazyToStrictByteString :: L.ByteString -> S.ByteString +#if MIN_VERSION_bytestring(0,10,0) +lazyToStrictByteString = L.toStrict +#else +lazyToStrictByteString = packChunks + +-- packChunks is taken from the blaze-builder package. + +-- | Pack the chunks of a lazy bytestring into a single strict bytestring. +packChunks :: L.ByteString -> S.ByteString +packChunks lbs = S.unsafeCreate (fromIntegral $ L.length lbs) (copyChunks lbs) + where + copyChunks !L.Empty !_pf = return () + copyChunks !(L.Chunk (S.PS fpbuf o l) lbs') !pf = do + withForeignPtr fpbuf $ \pbuf -> + copyBytes pf (pbuf `plusPtr` o) l + copyChunks lbs' (pf `plusPtr` l) +#endif diff --git a/bundled/Data/Text/Lazy/Builder/Scientific.hs b/bundled/Data/Text/Lazy/Builder/Scientific.hs new file mode 100644 index 0000000..60b6a2f --- /dev/null +++ b/bundled/Data/Text/Lazy/Builder/Scientific.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings, Safe #-} + +module Data.Text.Lazy.Builder.Scientific + ( scientificBuilder + , formatScientificBuilder + , FPFormat(..) + ) where + +import Data.Scientific (Scientific) +import qualified Data.Scientific as Scientific + +import Data.Text.Lazy.Builder.RealFloat (FPFormat(..)) + +import Data.Text.Lazy.Builder (Builder, fromString, singleton, fromText) +import Data.Text.Lazy.Builder.Int (decimal) +import qualified Data.Text as T (replicate) +import Utils (roundTo, i2d) + +import Data.Monoid ((<>)) + +-- | A @Text@ @Builder@ which renders a scientific number to full +-- precision, using standard decimal notation for arguments whose +-- absolute value lies between @0.1@ and @9,999,999@, and scientific +-- notation otherwise. +scientificBuilder :: Scientific -> Builder +scientificBuilder = formatScientificBuilder Generic Nothing + +-- | Like 'scientificBuilder' but provides rendering options. +formatScientificBuilder :: FPFormat + -> Maybe Int -- ^ Number of decimal places to render. + -> Scientific + -> Builder +formatScientificBuilder fmt decs scntfc + | scntfc < 0 = singleton '-' <> doFmt fmt (Scientific.toDecimalDigits (-scntfc)) + | otherwise = doFmt fmt (Scientific.toDecimalDigits scntfc) + where + doFmt format (is, e) = + let ds = map i2d is in + case format of + Generic -> + doFmt (if e < 0 || e > 7 then Exponent else Fixed) + (is,e) + Exponent -> + case decs of + Nothing -> + let show_e' = decimal (e-1) in + case ds of + "0" -> "0.0e0" + [d] -> singleton d <> ".0e" <> show_e' + (d:ds') -> singleton d <> singleton '.' <> fromString ds' <> singleton 'e' <> show_e' + [] -> error $ "Data.Text.Lazy.Builder.Scientific.formatScientificBuilder" ++ + "/doFmt/Exponent: []" + Just dec -> + let dec' = max dec 1 in + case is of + [0] -> "0." <> fromText (T.replicate dec' "0") <> "e0" + _ -> + let (ei,is') = roundTo (dec'+1) is + in case map i2d (if ei > 0 then init is' else is') of + [] -> mempty + d:ds' -> singleton d <> singleton '.' <> fromString ds' <> singleton 'e' <> decimal (e-1+ei) + Fixed -> + let + mk0 ls = case ls of { "" -> "0" ; _ -> fromString ls} + in + case decs of + Nothing + | e <= 0 -> "0." <> fromText (T.replicate (-e) "0") <> fromString ds + | otherwise -> + let + f 0 s rs = mk0 (reverse s) <> singleton '.' <> mk0 rs + f n s "" = f (n-1) ('0':s) "" + f n s (r:rs) = f (n-1) (r:s) rs + in + f e "" ds + Just dec -> + let dec' = max dec 0 in + if e >= 0 then + let + (ei,is') = roundTo (dec' + e) is + (ls,rs) = splitAt (e+ei) (map i2d is') + in + mk0 ls <> (if null rs then "" else singleton '.' <> fromString rs) + else + let (ei,is') = roundTo dec' (replicate (-e) 0 ++ is) + in case map i2d (if ei > 0 then is' else 0:is') of + [] -> mempty + d:ds' -> singleton d <> (if null ds' then "" else singleton '.' <> fromString ds') diff --git a/bundled/GHC/Integer/Compat.hs b/bundled/GHC/Integer/Compat.hs new file mode 100644 index 0000000..a8e18ca --- /dev/null +++ b/bundled/GHC/Integer/Compat.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} + +module GHC.Integer.Compat (divInteger, quotRemInteger, quotInteger) where + +import GHC.Integer (quotRemInteger, quotInteger) + +#if MIN_VERSION_base(4,15,0) +import GHC.Integer (divInteger) +#else + +#ifdef MIN_VERSION_integer_simple + +#if MIN_VERSION_integer_simple(0,1,1) +import GHC.Integer (divInteger) +#else +divInteger :: Integer -> Integer -> Integer +divInteger = div +#endif + +#else + +#if MIN_VERSION_integer_gmp(0,5,1) +import GHC.Integer (divInteger) +#else +divInteger :: Integer -> Integer -> Integer +divInteger = div +#endif + +#endif +#endif diff --git a/bundled/GHC/Integer/Logarithms/Compat.hs b/bundled/GHC/Integer/Logarithms/Compat.hs new file mode 100644 index 0000000..564c941 --- /dev/null +++ b/bundled/GHC/Integer/Logarithms/Compat.hs @@ -0,0 +1,155 @@ +-- | +-- Module: GHC.Integer.Logarithms.Compat +-- Copyright: (c) 2011 Daniel Fischer +-- Licence: MIT +-- Maintainer: Daniel Fischer +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- +-- Low level stuff for integer logarithms. +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif +module GHC.Integer.Logarithms.Compat + ( -- * Functions + integerLogBase# + , integerLog2# + , wordLog2# + ) where + +#if __GLASGOW_HASKELL__ >= 702 + +-- Stuff is already there +import GHC.Integer.Logarithms + +#else + +-- We have to define it here +#include "MachDeps.h" + +import GHC.Base +import GHC.Integer.GMP.Internals + +#if (WORD_SIZE_IN_BITS != 32) && (WORD_SIZE_IN_BITS != 64) +#error Only word sizes 32 and 64 are supported. +#endif + + +#if WORD_SIZE_IN_BITS == 32 + +#define WSHIFT 5 +#define MMASK 31 + +#else + +#define WSHIFT 6 +#define MMASK 63 + +#endif + +-- Reference implementation only, the algorithm in M.NT.Logarithms is better. + +-- | Calculate the integer logarithm for an arbitrary base. +-- The base must be greater than 1, the second argument, the number +-- whose logarithm is sought; should be positive, otherwise the +-- result is meaningless. +-- +-- > base ^ integerLogBase# base m <= m < base ^ (integerLogBase# base m + 1) +-- +-- for @base > 1@ and @m > 0@. +integerLogBase# :: Integer -> Integer -> Int# +integerLogBase# b m = case step b of + (# _, e #) -> e + where + step pw = + if m < pw + then (# m, 0# #) + else case step (pw * pw) of + (# q, e #) -> + if q < pw + then (# q, 2# *# e #) + else (# q `quot` pw, 2# *# e +# 1# #) + +-- | Calculate the integer base 2 logarithm of an 'Integer'. +-- The calculation is much more efficient than for the general case. +-- +-- The argument must be strictly positive, that condition is /not/ checked. +integerLog2# :: Integer -> Int# +integerLog2# (S# i) = wordLog2# (int2Word# i) +integerLog2# (J# s ba) = check (s -# 1#) + where + check i = case indexWordArray# ba i of + 0## -> check (i -# 1#) + w -> wordLog2# w +# (uncheckedIShiftL# i WSHIFT#) + +-- | This function calculates the integer base 2 logarithm of a 'Word#'. +-- @'wordLog2#' 0## = -1#@. +{-# INLINE wordLog2# #-} +wordLog2# :: Word# -> Int# +wordLog2# w = + case leadingZeros of + BA lz -> + let zeros u = indexInt8Array# lz (word2Int# u) in +#if WORD_SIZE_IN_BITS == 64 + case uncheckedShiftRL# w 56# of + a -> + if a `neWord#` 0## + then 64# -# zeros a + else + case uncheckedShiftRL# w 48# of + b -> + if b `neWord#` 0## + then 56# -# zeros b + else + case uncheckedShiftRL# w 40# of + c -> + if c `neWord#` 0## + then 48# -# zeros c + else + case uncheckedShiftRL# w 32# of + d -> + if d `neWord#` 0## + then 40# -# zeros d + else +#endif + case uncheckedShiftRL# w 24# of + e -> + if e `neWord#` 0## + then 32# -# zeros e + else + case uncheckedShiftRL# w 16# of + f -> + if f `neWord#` 0## + then 24# -# zeros f + else + case uncheckedShiftRL# w 8# of + g -> + if g `neWord#` 0## + then 16# -# zeros g + else 8# -# zeros w + +-- Lookup table +data BA = BA ByteArray# + +leadingZeros :: BA +leadingZeros = + let mkArr s = + case newByteArray# 256# s of + (# s1, mba #) -> + case writeInt8Array# mba 0# 9# s1 of + s2 -> + let fillA lim val idx st = + if idx ==# 256# + then st + else if idx <# lim + then case writeInt8Array# mba idx val st of + nx -> fillA lim val (idx +# 1#) nx + else fillA (2# *# lim) (val -# 1#) idx st + in case fillA 2# 8# 1# s2 of + s3 -> case unsafeFreezeByteArray# mba s3 of + (# _, ba #) -> ba + in case mkArr realWorld# of + b -> BA b + +#endif diff --git a/bundled/Math/NumberTheory/Logarithms.hs b/bundled/Math/NumberTheory/Logarithms.hs new file mode 100644 index 0000000..3729484 --- /dev/null +++ b/bundled/Math/NumberTheory/Logarithms.hs @@ -0,0 +1,330 @@ +-- | +-- Module: Math.NumberTheory.Logarithms +-- Copyright: (c) 2011 Daniel Fischer +-- Licence: MIT +-- Maintainer: Daniel Fischer +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- +-- Integer Logarithms. For efficiency, the internal representation of 'Integer's +-- from integer-gmp is used. +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE Trustworthy #-} +module Math.NumberTheory.Logarithms + ( -- * Integer logarithms with input checks + integerLogBase + , integerLog2 + , integerLog10 + + , naturalLogBase + , naturalLog2 + , naturalLog10 + + , intLog2 + , wordLog2 + + -- * Integer logarithms without input checks + -- + -- | These functions are total, however, don't rely on the values with out-of-domain arguments. + , integerLogBase' + , integerLog2' + , integerLog10' + + , intLog2' + , wordLog2' + ) where + +import GHC.Exts + +import Data.Bits +import Data.Array.Unboxed +import Numeric.Natural + +#ifdef MIN_VERSION_ghc_bignum +import qualified GHC.Num.Natural as BN +#endif + +import GHC.Integer.Logarithms.Compat +#if MIN_VERSION_base(4,8,0) && defined(MIN_VERSION_integer_gmp) +import GHC.Integer.GMP.Internals (Integer (..)) +import GHC.Natural +#endif + +#if CheckBounds +import Data.Array.IArray (IArray, (!)) +#else +import Data.Array.Base (unsafeAt) +#endif + +-- | Calculate the integer logarithm for an arbitrary base. +-- The base must be greater than 1, the second argument, the number +-- whose logarithm is sought, must be positive, otherwise an error is thrown. +-- If @base == 2@, the specialised version is called, which is more +-- efficient than the general algorithm. +-- +-- Satisfies: +-- +-- > base ^ integerLogBase base m <= m < base ^ (integerLogBase base m + 1) +-- +-- for @base > 1@ and @m > 0@. +integerLogBase :: Integer -> Integer -> Int +integerLogBase b n + | n < 1 = error "Math.NumberTheory.Logarithms.integerLogBase: argument must be positive." + | n < b = 0 + | b == 2 = integerLog2' n + | b < 2 = error "Math.NumberTheory.Logarithms.integerLogBase: base must be greater than one." + | otherwise = integerLogBase' b n + +-- | Calculate the integer logarithm of an 'Integer' to base 2. +-- The argument must be positive, otherwise an error is thrown. +integerLog2 :: Integer -> Int +integerLog2 n + | n < 1 = error "Math.NumberTheory.Logarithms.integerLog2: argument must be positive" + | otherwise = I# (integerLog2# n) + +-- | Cacluate the integer logarithm for an arbitrary base. +-- The base must be greater than 1, the second argument, the number +-- whose logarithm is sought, must be positive, otherwise an error is thrown. +-- If @base == 2@, the specialised version is called, which is more +-- efficient than the general algorithm. +-- +-- Satisfies: +-- +-- > base ^ integerLogBase base m <= m < base ^ (integerLogBase base m + 1) +-- +-- for @base > 1@ and @m > 0@. +naturalLogBase :: Natural -> Natural -> Int +naturalLogBase b n + | n < 1 = error "Math.NumberTheory.Logarithms.naturalLogBase: argument must be positive." + | n < b = 0 + | b == 2 = naturalLog2' n + | b < 2 = error "Math.NumberTheory.Logarithms.naturalLogBase: base must be greater than one." + | otherwise = naturalLogBase' b n + +-- | Calculate the natural logarithm of an 'Natural' to base 2. +-- The argument must be non-zero, otherwise an error is thrown. +naturalLog2 :: Natural -> Int +naturalLog2 n + | n < 1 = error "Math.NumberTheory.Logarithms.naturalLog2: argument must be non-zero" + | otherwise = I# (naturalLog2# n) + +-- | Calculate the integer logarithm of an 'Int' to base 2. +-- The argument must be positive, otherwise an error is thrown. +intLog2 :: Int -> Int +intLog2 (I# i#) + | isTrue# (i# <# 1#) = error "Math.NumberTheory.Logarithms.intLog2: argument must be positive" + | otherwise = I# (wordLog2# (int2Word# i#)) + +-- | Calculate the integer logarithm of a 'Word' to base 2. +-- The argument must be positive, otherwise an error is thrown. +wordLog2 :: Word -> Int +wordLog2 (W# w#) + | isTrue# (w# `eqWord#` 0##) = error "Math.NumberTheory.Logarithms.wordLog2: argument must not be 0." + | otherwise = I# (wordLog2# w#) + +-- | Same as 'integerLog2', but without checks, saves a little time when +-- called often for known good input. +integerLog2' :: Integer -> Int +integerLog2' n = I# (integerLog2# n) + +-- | Same as 'naturalLog2', but without checks, saves a little time when +-- called often for known good input. +naturalLog2' :: Natural -> Int +naturalLog2' n = I# (naturalLog2# n) + +-- | Same as 'intLog2', but without checks, saves a little time when +-- called often for known good input. +intLog2' :: Int -> Int +intLog2' (I# i#) = I# (wordLog2# (int2Word# i#)) + +-- | Same as 'wordLog2', but without checks, saves a little time when +-- called often for known good input. +wordLog2' :: Word -> Int +wordLog2' (W# w#) = I# (wordLog2# w#) + +-- | Calculate the integer logarithm of an 'Integer' to base 10. +-- The argument must be positive, otherwise an error is thrown. +integerLog10 :: Integer -> Int +integerLog10 n + | n < 1 = error "Math.NumberTheory.Logarithms.integerLog10: argument must be positive" + | otherwise = integerLog10' n + +-- | Calculate the integer logarithm of an 'Integer' to base 10. +-- The argument must be not zero, otherwise an error is thrown. +naturalLog10 :: Natural -> Int +naturalLog10 n + | n < 1 = error "Math.NumberTheory.Logarithms.naturalaLog10: argument must be non-zero" + | otherwise = naturalLog10' n + +-- | Same as 'integerLog10', but without a check for a positive +-- argument. Saves a little time when called often for known good +-- input. +integerLog10' :: Integer -> Int +integerLog10' n + | n < 10 = 0 + | n < 100 = 1 + | otherwise = ex + integerLog10' (n `quot` 10 ^ ex) + where + ln = I# (integerLog2# n) + -- u/v is a good approximation of log 2/log 10 + u = 1936274 + v = 6432163 + -- so ex is a good approximation to integerLogBase 10 n + ex = fromInteger ((u * fromIntegral ln) `quot` v) + +-- | Same as 'naturalLog10', but without a check for a positive +-- argument. Saves a little time when called often for known good +-- input. +naturalLog10' :: Natural -> Int +naturalLog10' n + | n < 10 = 0 + | n < 100 = 1 + | otherwise = ex + naturalLog10' (n `quot` 10 ^ ex) + where + ln = I# (naturalLog2# n) + -- u/v is a good approximation of log 2/log 10 + u = 1936274 + v = 6432163 + -- so ex is a good approximation to naturalLogBase 10 n + ex = fromInteger ((u * fromIntegral ln) `quot` v) + +-- | Same as 'integerLogBase', but without checks, saves a little time when +-- called often for known good input. +integerLogBase' :: Integer -> Integer -> Int +integerLogBase' b n + | n < b = 0 + | ln-lb < lb = 1 -- overflow safe version of ln < 2*lb, implies n < b*b + | b < 33 = let bi = fromInteger b + ix = 2*bi-4 + -- u/v is a good approximation of log 2/log b + u = logArr `unsafeAt` ix + v = logArr `unsafeAt` (ix+1) + -- hence ex is a rather good approximation of integerLogBase b n + -- most of the time, it will already be exact + ex = fromInteger ((fromIntegral u * fromIntegral ln) `quot` fromIntegral v) + in case u of + 1 -> ln `quot` v -- a power of 2, easy + _ -> ex + integerLogBase' b (n `quot` b ^ ex) + | otherwise = let -- shift b so that 16 <= bi < 32 + bi = fromInteger (b `shiftR` (lb-4)) + -- we choose an approximation of log 2 / log (bi+1) to + -- be sure we underestimate + ix = 2*bi-2 + -- u/w is a reasonably good approximation to log 2/log b + -- it is too small, but not by much, so the recursive call + -- should most of the time be caught by one of the first + -- two guards unless n is huge, but then it'd still be + -- a call with a much smaller second argument. + u = fromIntegral $ logArr `unsafeAt` ix + v = fromIntegral $ logArr `unsafeAt` (ix+1) + w = v + u*fromIntegral (lb-4) + ex = fromInteger ((u * fromIntegral ln) `quot` w) + in ex + integerLogBase' b (n `quot` b ^ ex) + where + lb = integerLog2' b + ln = integerLog2' n + +-- | Same as 'naturalLogBase', but without checks, saves a little time when +-- called often for known good input. +naturalLogBase' :: Natural -> Natural -> Int +naturalLogBase' b n + | n < b = 0 + | ln-lb < lb = 1 -- overflow safe version of ln < 2*lb, implies n < b*b + | b < 33 = let bi = fromIntegral b + ix = 2*bi-4 + -- u/v is a good approximation of log 2/log b + u = logArr `unsafeAt` ix + v = logArr `unsafeAt` (ix+1) + -- hence ex is a rather good approximation of integerLogBase b n + -- most of the time, it will already be exact + ex = fromNatural ((fromIntegral u * fromIntegral ln) `quot` fromIntegral v) + in case u of + 1 -> ln `quot` v -- a power of 2, easy + _ -> ex + naturalLogBase' b (n `quot` b ^ ex) + | otherwise = let -- shift b so that 16 <= bi < 32 + bi = fromNatural (b `shiftR` (lb-4)) + -- we choose an approximation of log 2 / log (bi+1) to + -- be sure we underestimate + ix = 2*bi-2 + -- u/w is a reasonably good approximation to log 2/log b + -- it is too small, but not by much, so the recursive call + -- should most of the time be caught by one of the first + -- two guards unless n is huge, but then it'd still be + -- a call with a much smaller second argument. + u = fromIntegral $ logArr `unsafeAt` ix + v = fromIntegral $ logArr `unsafeAt` (ix+1) + w = v + u*fromIntegral (lb-4) + ex = fromNatural ((u * fromIntegral ln) `quot` w) + in ex + naturalLogBase' b (n `quot` b ^ ex) + where + lb = naturalLog2' b + ln = naturalLog2' n + +-- Lookup table for logarithms of 2 <= k <= 32 +-- In each row "x , y", x/y is a good rational approximation of log 2 / log k. +-- For the powers of 2, it is exact, otherwise x/y < log 2/log k, since we don't +-- want to overestimate integerLogBase b n = floor $ (log 2/log b)*logBase 2 n. +logArr :: UArray Int Int +logArr = listArray (0, 61) + [ 1 , 1, + 190537 , 301994, + 1 , 2, + 1936274 , 4495889, + 190537 , 492531, + 91313 , 256348, + 1 , 3, + 190537 , 603988, + 1936274 , 6432163, + 1686227 , 5833387, + 190537 , 683068, + 5458 , 20197, + 91313 , 347661, + 416263 , 1626294, + 1 , 4, + 32631 , 133378, + 190537 , 794525, + 163451 , 694328, + 1936274 , 8368437, + 1454590 , 6389021, + 1686227 , 7519614, + 785355 , 3552602, + 190537 , 873605, + 968137 , 4495889, + 5458 , 25655, + 190537 , 905982, + 91313 , 438974, + 390321 , 1896172, + 416263 , 2042557, + 709397 , 3514492, + 1 , 5 + ] + +------------------------------------------------------------------------------- +-- Unsafe +------------------------------------------------------------------------------- + +#if CheckBounds +unsafeAt :: (IArray a e, Ix i) => a i e -> i -> e +unsafeAt = (!) +#endif + +------------------------------------------------------------------------------- +-- Natural helpers +------------------------------------------------------------------------------- + +fromNatural :: Num a => Natural -> a +fromNatural = fromIntegral + +naturalLog2# :: Natural -> Int# +#ifdef MIN_VERSION_ghc_bignum +naturalLog2# n = word2Int# (BN.naturalLog2# n) +#else +#if MIN_VERSION_base(4,8,0) && defined(MIN_VERSION_integer_gmp) +naturalLog2# (NatS# b) = wordLog2# b +naturalLog2# (NatJ# n) = integerLog2# (Jp# n) +#else +naturalLog2# n = integerLog2# (toInteger n) +#endif +#endif diff --git a/bundled/Math/NumberTheory/Powers/Integer.hs b/bundled/Math/NumberTheory/Powers/Integer.hs new file mode 100644 index 0000000..aad3c60 --- /dev/null +++ b/bundled/Math/NumberTheory/Powers/Integer.hs @@ -0,0 +1,39 @@ +-- | +-- Module: Math.NumberTheory.Powers.Integer +-- Copyright: (c) 2011-2014 Daniel Fischer +-- Licence: MIT +-- Maintainer: Daniel Fischer +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- +-- Potentially faster power function for 'Integer' base and 'Int' +-- or 'Word' exponent. +-- +{-# LANGUAGE Safe #-} +module Math.NumberTheory.Powers.Integer + {-# DEPRECATED "It is no faster than (^)" #-} + ( integerPower + , integerWordPower + ) where + +-- | Power of an 'Integer' by the left-to-right repeated squaring algorithm. +-- This needs two multiplications in each step while the right-to-left +-- algorithm needs only one multiplication for 0-bits, but here the +-- two factors always have approximately the same size, which on average +-- gains a bit when the result is large. +-- +-- For small results, it is unlikely to be any faster than '(^)', quite +-- possibly slower (though the difference shouldn't be large), and for +-- exponents with few bits set, the same holds. But for exponents with +-- many bits set, the speedup can be significant. +-- +-- /Warning:/ No check for the negativity of the exponent is performed, +-- a negative exponent is interpreted as a large positive exponent. +integerPower :: Integer -> Int -> Integer +integerPower = (^) +{-# DEPRECATED integerPower "Use (^) instead" #-} + +-- | Same as 'integerPower', but for exponents of type 'Word'. +integerWordPower :: Integer -> Word -> Integer +integerWordPower = (^) +{-# DEPRECATED integerWordPower "Use (^) instead" #-} diff --git a/bundled/Math/NumberTheory/Powers/Natural.hs b/bundled/Math/NumberTheory/Powers/Natural.hs new file mode 100644 index 0000000..f331b8f --- /dev/null +++ b/bundled/Math/NumberTheory/Powers/Natural.hs @@ -0,0 +1,41 @@ +-- | +-- Module: Math.NumberTheory.Powers.Natural +-- Copyright: (c) 2011-2014 Daniel Fischer +-- Licence: MIT +-- Maintainer: Daniel Fischer +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- +-- Potentially faster power function for 'Natural' base and 'Int' +-- or 'Word' exponent. +-- +{-# LANGUAGE Safe #-} +module Math.NumberTheory.Powers.Natural + {-# DEPRECATED "It is no faster than (^)" #-} + ( naturalPower + , naturalWordPower + ) where + +import Numeric.Natural (Natural) + +-- | Power of an 'Natural' by the left-to-right repeated squaring algorithm. +-- This needs two multiplications in each step while the right-to-left +-- algorithm needs only one multiplication for 0-bits, but here the +-- two factors always have approximately the same size, which on average +-- gains a bit when the result is large. +-- +-- For small results, it is unlikely to be any faster than '(^)', quite +-- possibly slower (though the difference shouldn't be large), and for +-- exponents with few bits set, the same holds. But for exponents with +-- many bits set, the speedup can be significant. +-- +-- /Warning:/ No check for the negativity of the exponent is performed, +-- a negative exponent is interpreted as a large positive exponent. +naturalPower :: Natural -> Int -> Natural +naturalPower = (^) +{-# DEPRECATED naturalPower "Use (^) instead" #-} + +-- | Same as 'naturalPower', but for exponents of type 'Word'. +naturalWordPower :: Natural -> Word -> Natural +naturalWordPower = (^) +{-# DEPRECATED naturalWordPower "Use (^) instead" #-} diff --git a/bundled/Network/ONCRPC/XDR.hs b/bundled/Network/ONCRPC/XDR.hs new file mode 100644 index 0000000..cc535e2 --- /dev/null +++ b/bundled/Network/ONCRPC/XDR.hs @@ -0,0 +1,13 @@ +-- | XDR: External Data Representation as described in RFC4506 +-- +-- This module should be imported qualified, e.g., as @XDR@. + +module Network.ONCRPC.XDR + ( module Network.ONCRPC.XDR.Types + , module Network.ONCRPC.XDR.Array + , module Network.ONCRPC.XDR.Serial + ) where + +import Network.ONCRPC.XDR.Types +import Network.ONCRPC.XDR.Array +import Network.ONCRPC.XDR.Serial diff --git a/bundled/Network/ONCRPC/XDR/Array.hs b/bundled/Network/ONCRPC/XDR/Array.hs new file mode 100644 index 0000000..bc61306 --- /dev/null +++ b/bundled/Network/ONCRPC/XDR/Array.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +{- | Various kinds of arrays (lists, vectors, bytestrings) with statically +asserted length constraints encoded in their type. +-} +module Network.ONCRPC.XDR.Array ( + KnownNat, + KnownOrdering, + LengthArray, + FixedLengthArray, + fixedLengthArrayLength, + BoundedLengthArray, + boundedLengthArrayBound, + unLengthArray, + unsafeLengthArray, + lengthArray, + lengthArray', + boundLengthArray, + boundLengthArrayFromList, + padLengthArray, + constLengthArray, + emptyFixedLengthArray, + emptyBoundedLengthArray, + expandBoundedLengthArray, + boundFixedLengthArray, + appendLengthArray, + fromLengthList, +) where + +import Prelude hiding (drop, length, replicate, take) + +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.List qualified as List +import Data.Maybe (fromJust, fromMaybe) +import Data.Proxy (Proxy (..)) +import Data.String (IsString (..)) +import Data.Vector qualified as V +import Data.Word (Word8) +import GHC.Stack (HasCallStack) +import GHC.TypeLits (KnownNat, Nat, natVal, type CmpNat, type (+)) + +class HasLength a where + length :: a -> Int + + -- | Equivalent to @'compare' . 'length'@ but allows more efficient + -- implementations + compareLength :: a -> Int -> Ordering + compareLength = compare . length + +class (Monoid a, HasLength a) => Array a where + type Elem a + take :: Int -> a -> a + replicate :: Int -> Elem a -> a + fromList :: [Elem a] -> a + +instance HasLength [a] where + length = List.length + compareLength [] n = compare 0 n + compareLength (_ : l) n = compareLength l (n - 1) +instance Array [a] where + type Elem [a] = a + take = List.take + replicate = List.replicate + fromList = id + +instance HasLength (V.Vector a) where + length = V.length +instance Array (V.Vector a) where + type Elem (V.Vector a) = a + take = V.take + replicate = V.replicate + fromList = V.fromList + +instance HasLength BS.ByteString where + length = BS.length +instance Array BS.ByteString where + type Elem BS.ByteString = Word8 + take = BS.take + replicate = BS.replicate + fromList = BS.pack + +instance HasLength BSL.ByteString where + length = fromIntegral . BSL.length + compareLength b n + | BSL.null b' = LT + | BSL.null (BSL.tail b') = EQ + | otherwise = GT + where + b' = BSL.drop (fromIntegral n - 1) b +instance Array BSL.ByteString where + type Elem BSL.ByteString = Word8 + take = BSL.take . fromIntegral + replicate = BSL.replicate . fromIntegral + fromList = BSL.pack + +class KnownOrdering (o :: Ordering) where + orderingVal :: proxy o -> Ordering + +instance KnownOrdering 'LT where orderingVal _ = LT +instance KnownOrdering 'EQ where orderingVal _ = EQ +instance KnownOrdering 'GT where orderingVal _ = GT + +-- | Assertion that the contained array satisfies @'compareLength' a n = o@ +newtype LengthArray (o :: Ordering) (n :: Nat) a + = LengthArray {unLengthArray :: a} + deriving (Eq, Ord, Show) + +instance (HasLength a) => HasLength (LengthArray o n a) where + length = length . unLengthArray + compareLength = compareLength . unLengthArray + +-- | Assertion that the contained array is exactly a static length +type FixedLengthArray n a = LengthArray 'EQ n a + +-- | Assertion that the contained array is at most a static length (inclusive) +type BoundedLengthArray n a = LengthArray 'LT (n + 1) a + +lengthArrayOrdering :: + forall o n a. (KnownOrdering o) => LengthArray o n a -> Ordering +lengthArrayOrdering _ = orderingVal (Proxy :: Proxy o) + +lengthArrayBound :: forall o n a. (KnownNat n) => LengthArray o n a -> Int +lengthArrayBound _ = fromInteger $ natVal (Proxy :: Proxy n) + +orderingOp :: Ordering -> Char +orderingOp LT = '<' +orderingOp EQ = '=' +orderingOp GT = '>' + +describeLengthArray :: + (KnownOrdering o, KnownNat n) => LengthArray o n a -> String +describeLengthArray a = + orderingOp (lengthArrayOrdering a) : show (lengthArrayBound a) + +-- | Static length of a 'FixedLengthArray' +fixedLengthArrayLength :: (KnownNat n) => LengthArray 'EQ n a -> Int +fixedLengthArrayLength = lengthArrayBound + +-- | Static upper-bound (inclusive) of a 'BoundedLengthArray' +boundedLengthArrayBound :: (KnownNat n) => LengthArray 'LT n a -> Int +boundedLengthArrayBound = subtract 1 . lengthArrayBound + +{- | Unsafely create a 'LengthArray' without checking the length bound +assertion. May cause unpredictable behavior if the bound does not hold. +-} +unsafeLengthArray :: a -> LengthArray o n a +unsafeLengthArray = LengthArray + +checkLengthArray :: + (KnownOrdering o, KnownNat n, HasLength a) => LengthArray o n a -> Bool +checkLengthArray l@(LengthArray a) = + compareLength a (lengthArrayBound l) == lengthArrayOrdering l + +{- | Safely create a 'LengthArray' out of an array if it conforms to the static +length assertion. +-} +lengthArray :: + forall o n a. + (KnownOrdering o, KnownNat n, HasLength a) => + a -> + Maybe (LengthArray o n a) +lengthArray a + | checkLengthArray l = Just l + | otherwise = Nothing + where + l = LengthArray a :: LengthArray o n a + +{- | Create a 'LengthArray' or runtime error if the assertion fails: +@fromMaybe undefined . 'lengthArray'@ +-} +lengthArray' :: + forall o n a. + (HasCallStack, KnownOrdering o, KnownNat n, HasLength a) => + a -> + LengthArray o n a +lengthArray' a = + fromMaybe + (error $ "lengthArray': fails check " ++ describeLengthArray (fromJust la)) + la + where + la = lengthArray a + +-- | Create a 'BoundedLengthArray' by trimming the given array if necessary. +boundLengthArray :: (KnownNat n, Array a) => a -> LengthArray 'LT n a +boundLengthArray a = l + where + l = LengthArray $ take (boundedLengthArrayBound l) a + +-- | Create a 'BoundedLengthArray' by trimming the given array if necessary. +boundLengthArrayFromList :: + (KnownNat n, Array a) => [Elem a] -> LengthArray 'LT n a +boundLengthArrayFromList a = l + where + l = LengthArray $ fromList $ take (boundedLengthArrayBound l) a + +{- | Create a 'FixedLengthArray' by trimming or padding (on the right) +as necessary. +-} +padLengthArray :: (KnownNat n, Array a) => a -> Elem a -> LengthArray 'EQ n a +padLengthArray a p = l + where + a' = case compareLength a n of + LT -> a <> replicate (n - length a) p + EQ -> a + GT -> take n a + n = fixedLengthArrayLength l + l = LengthArray a' + +-- | Create a 'FixedLengthArray' filled with the same value. +constLengthArray :: (KnownNat n, Array a) => Elem a -> LengthArray 'EQ n a +constLengthArray p = l + where + l = LengthArray $ replicate (fixedLengthArrayLength l) p + +instance + (KnownOrdering o, KnownNat n, IsString a, HasLength a) => + IsString (LengthArray o n a) + where + fromString s = + fromMaybe + ( error $ + "String " + ++ show s + ++ " fails LengthArray check " + ++ describeLengthArray (fromJust ls) + ) + ls + where + ls = lengthArray $ fromString s + +-- | An empty 'FixedLengthArray'. +emptyFixedLengthArray :: (Array a) => LengthArray 'EQ 0 a +emptyFixedLengthArray = LengthArray mempty + +-- | An empty 'BoundedLengthArray'. +emptyBoundedLengthArray :: (CmpNat 0 n ~ 'LT, Array a) => LengthArray 'LT n a +emptyBoundedLengthArray = LengthArray mempty + +-- | Grow the bound of a 'BoundedLengthArray'. +expandBoundedLengthArray :: + (CmpNat n m ~ 'LT) => LengthArray 'LT n a -> LengthArray 'LT m a +expandBoundedLengthArray = LengthArray . unLengthArray + +-- | Convert a 'FixedLengthArray' to a 'BoundedLengthArray'. +boundFixedLengthArray :: + (CmpNat n m ~ 'LT) => LengthArray 'EQ n a -> LengthArray 'LT m a +boundFixedLengthArray = LengthArray . unLengthArray + +-- | Append to two 'LengthArray's. +appendLengthArray :: + (Monoid a) => + LengthArray o n a -> + LengthArray o m a -> + LengthArray o (n + m) a +appendLengthArray (LengthArray a) (LengthArray b) = LengthArray $ mappend a b + +fromLengthList :: (Array a) => LengthArray o n [Elem a] -> LengthArray o n a +fromLengthList = LengthArray . fromList . unLengthArray diff --git a/bundled/Network/ONCRPC/XDR/Cabal.hs b/bundled/Network/ONCRPC/XDR/Cabal.hs new file mode 100644 index 0000000..90ea934 --- /dev/null +++ b/bundled/Network/ONCRPC/XDR/Cabal.hs @@ -0,0 +1,61 @@ +-- | Cabal utilities for XDR processing. +module Network.ONCRPC.XDR.Cabal + ( ppRPCGenSuffixHandler + ) where + +import Data.Char (toLower) +import Data.Coerce +import Data.List (intercalate, isPrefixOf) +import Data.Maybe (fromMaybe, mapMaybe) +import Distribution.PackageDescription (BuildInfo(customFieldsBI)) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, ComponentLocalBuildInfo) +import Distribution.Simple.PreProcess (PreProcessor(..), PPSuffixHandler, Suffix(..)) +import Distribution.Simple.Utils (info) +import System.FilePath ((), dropExtension, splitDirectories) + +import Network.ONCRPC.XDR.Generate + +runRPCGen :: [(String, String)] -> (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO () +runRPCGen custom (indir, infile) (outdir, outfile) verb = do + info verb $ "hdrpcgen " ++ inpath ++ " with " ++ show opts + writeFile outpath + =<< generateFromFile opts inpath + where + opts = GenerateOptions + { generateModuleName = modname + , generateReidentOptions = ReidentOptions + { reidentUpperPrefix = fromMaybe "" $ opt "upper-prefix" + , reidentLowerPrefix = fromMaybe "" $ opt "lower-prefix" + , reidentJoinField = joinopt "field" + , reidentJoinProcedure = joinopt "procedure" + } + } + joinopt t = case (maybe False boolish $ opt $ t ++ "s-unique", opt $ "join-" ++ t) of + (False, j) -> Just $ fromMaybe "'" j + (True, Nothing) -> Nothing + (True, Just _) -> + error "x-rpcgen join and unique options are mutually exclusive" + boolish s = map toLower s `isPrefixOf` "true" + opt f = lookup f custom + inpath = indir infile + outpath = outdir outfile + modname = intercalate "." $ splitDirectories $ dropExtension infile + +ppRPCGenCustomField :: (String, String) -> Maybe (String, String) +ppRPCGenCustomField ('x':'-':'r':'p':'c':'g':'e':'n':'-':f,v) = Just (f,v) +ppRPCGenCustomField _ = Nothing + +ppRPCGen :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppRPCGen bi _ _ = PreProcessor + { platformIndependent = True + , runPreProcessor = runRPCGen $ mapMaybe ppRPCGenCustomField $ customFieldsBI bi + , ppOrdering = undefined + } + +-- |Pre-processor for hsrpcgen. +-- You can use it by setting @'Distribution.Simple.UserHooks' { 'Distribution.Simple.hookedPrepProcessors' = ['ppRPCGenSuffixHandler'] }@. +-- Note that this will override the default alex @.x@ file handler. +-- You can also specify custom cabal fields corresponding to 'ReidentOptions' and command-line flags prefixed with @x-rpcgen-@: @{upper,lower}-prefix@, @join-{field,procedure}@, and @{field,procedure}s-unique}@. +ppRPCGenSuffixHandler :: PPSuffixHandler +ppRPCGenSuffixHandler = (coerce "x", ppRPCGen) diff --git a/bundled/Network/ONCRPC/XDR/Generate.hs b/bundled/Network/ONCRPC/XDR/Generate.hs new file mode 100644 index 0000000..ab09172 --- /dev/null +++ b/bundled/Network/ONCRPC/XDR/Generate.hs @@ -0,0 +1,306 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Generate Haskell code from XDR descriptions as per RFC4506 and RPC extensions from RFC5531 +module Network.ONCRPC.XDR.Generate + ( generateFromFile + , generate + , generateModule + , ReidentOptions(..) + , GenerateOptions(..) + , defaultReidentOptions + ) where + +import Control.Arrow ((***), (&&&)) +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.Char (isAlpha, isUpper) +import Data.Maybe (fromMaybe, maybeToList) +import qualified Language.Haskell.Exts.Build as HS +import Language.Haskell.Exts.Pretty (prettyPrintWithMode, PPHsMode(..), defaultMode) +import qualified Language.Haskell.Exts.Syntax as HS + +import qualified Network.ONCRPC.XDR as XDR +import Network.ONCRPC.XDR.Specification +import qualified Network.ONCRPC.XDR.Parse as XDR +import Network.ONCRPC.XDR.Reident + +name :: String -> HS.Name () +name "" = error "empty name" +name s@(c:_) + | isAlpha c || c == '_' = HS.Ident () s + | otherwise = HS.Symbol () s + +infix 9 !, !. +(!) :: String -> String -> HS.QName () +(!) "" = HS.UnQual () . name +(!) m = HS.Qual () (HS.ModuleName () m) . name + +(!.) :: String -> String -> HS.Exp () +_ !. [] = error "empty qualified name" +m !. n@(c:_) + | isUpper c || c == ':' = HS.Con () $ m ! n + | otherwise = HS.Var () $ m ! n + +instDecl :: HS.QName () -> String -> [HS.InstDecl ()] -> HS.Decl () +instDecl c t = HS.InstDecl () Nothing + (HS.IRule () Nothing Nothing $ HS.IHApp () (HS.IHCon () c) $ HS.TyCon () $ ""!t) + . Just + +dataDecl :: String -> [HS.ConDecl ()] -> [String] -> HS.Decl () +dataDecl n con derive = HS.DataDecl () (HS.DataType ()) Nothing (HS.DHead () $ HS.name n) + (map (HS.QualConDecl () Nothing Nothing) con) + [HS.Deriving () Nothing $ map (HS.IRule () Nothing Nothing . HS.IHCon () . ("Prelude"!)) derive] + +constantType :: HS.Type () +constantType = HS.TyForall () + Nothing + ( Just $ + HS.CxSingle () $ + HS.TypeA () (HS.TyApp () (HS.TyCon () ("Prelude"!"Integral")) t) + ) + t + where + t = HS.TyVar () $ HS.name "a" + +primType :: TypeSpecifier -> Maybe String +primType TypeInt = Just "Int" +primType TypeUnsignedInt = Just "UnsignedInt" +primType TypeHyper = Just "Hyper" +primType TypeUnsignedHyper = Just "UnsignedHyper" +primType TypeFloat = Just "Float" +primType TypeDouble = Just "Double" +primType TypeQuadruple = Just "Quadruple" +primType TypeBool = Just "Bool" +primType _ = Nothing + +specType :: TypeSpecifier -> Maybe (HS.Type ()) +specType (TypeIdentifier t) = Just $ HS.TyCon () $ ""!t +specType t = HS.TyCon () . (!) "XDR" <$> primType t + +specType' :: TypeSpecifier -> HS.Type () +specType' = + fromMaybe (error "parameter data structures are not supported") . specType + +lengthType :: String -> XDR.Length -> HS.Type () +lengthType t l = HS.TyApp () (HS.TyCon () $ "XDR"!t) $ HS.TyPromoted () $ HS.PromotedInteger () (toInteger l) (show l) + +descrType :: TypeDescriptor -> Maybe (HS.Type ()) +descrType (TypeSingle t) = specType t +descrType (TypeArray t (FixedLength l)) = HS.TyApp () (lengthType "FixedArray" l) <$> specType t +descrType (TypeArray t (VariableLength l)) = HS.TyApp () (lengthType "Array" l) <$> specType t +descrType (TypeOpaque (FixedLength l)) = Just $ lengthType "FixedOpaque" l +descrType (TypeOpaque (VariableLength l)) = Just $ lengthType "Opaque" l +descrType (TypeString (FixedLength l)) = Just $ lengthType "FixedString" l +descrType (TypeString (VariableLength l)) = Just $ lengthType "String" l +descrType (TypeOptional t) = HS.TyApp () (HS.TyCon () $ "XDR"!"Optional") <$> specType t + +declType' :: Declaration -> HS.Type () +declType' (Declaration n t) = fromMaybe (error $ "nested data structures are not supported: " ++ show n) $ descrType t + +strictType :: HS.Type () -> HS.Type () +strictType = HS.TyBang () (HS.BangedTy ()) (HS.NoUnpackPragma ()) + +declaration :: Declaration -> [HS.FieldDecl ()] +declaration (Declaration _ (TypeSingle (TypeStruct (StructBody dl)))) = + concatMap declaration dl +declaration d@(Declaration i _) = + [HS.FieldDecl () [HS.name i] $ strictType $ declType' d] + +optionalDeclaration :: OptionalDeclaration -> [HS.FieldDecl ()] +optionalDeclaration = foldMap declaration + +typeDef :: String -> HS.Decl () +typeDef = HS.simpleFun (HS.name "xdrType") (HS.name "_") . HS.strE + +fieldNames :: [HS.FieldDecl ()] -> [HS.Name ()] +fieldNames = concatMap $ \(HS.FieldDecl _ nl _) -> nl + +putFields :: HS.Exp () -> [HS.FieldDecl ()] -> HS.Exp () +putFields _ [] = HS.app ("Control.Applicative"!."pure") (HS.Con () $ HS.Special () $ HS.UnitCon ()) +putFields x l = foldl1 (flip HS.infixApp $ HS.QVarOp () $ "Control.Applicative"!"*>") + $ map (HS.app ("XDR"!."xdrPut") . flip HS.app x . HS.var) + $ fieldNames l + +getFields :: HS.Exp () -> [HS.FieldDecl ()] -> HS.Exp () +getFields n = foldl (\c _ -> HS.infixApp c (HS.QVarOp () $ "Control.Applicative"!"<*>") $ "XDR"!."xdrGet") n . fieldNames + +pureCon :: String -> HS.Exp () +pureCon = HS.app ("Control.Applicative"!."pure") . HS.Con () . (""!) + +sMatch :: String -> HS.Pat () -> HS.Exp () -> HS.Match () +sMatch n p e = HS.Match () (HS.name n) [p] (HS.UnGuardedRhs () e) Nothing + +definition :: Definition -> [HS.Decl ()] +definition (Definition n (TypeDef (TypeSingle (TypeEnum (EnumBody el))))) = + [ dataDecl n + (map (flip (HS.ConDecl ()) [] . HS.name . fst) el) + ["Eq", "Ord", "Enum", "Bounded", "Show"] + , instDecl ("XDR"!"XDR") n $ map (HS.InsDecl ()) + [ typeDef n + , HS.nameBind (HS.name "xdrPut") $ "XDR"!."xdrPutEnum" + , HS.nameBind (HS.name "xdrGet") $ "XDR"!."xdrGetEnum" + ] + , instDecl ("XDR"!"XDREnum") n $ map (HS.InsDecl ()) + [ HS.FunBind () $ map (\(i,v) -> + sMatch "xdrFromEnum" (HS.pApp (HS.name i) []) $ HS.intE $ toInteger v) + el + , HS.FunBind () $ map (\(i,v) -> + sMatch "xdrToEnum" (HS.intP $ toInteger v) $ HS.app ("Prelude"!."return") $ HS.Con () $ ""!i) + el ++ + [ sMatch "xdrToEnum" (HS.PWildCard ()) $ HS.app ("Prelude"!."fail") $ HS.strE $ "invalid " ++ n] + ] + ] +definition (Definition n (TypeDef (TypeSingle (TypeStruct (StructBody dl))))) = + [ dataDecl n + [HS.RecDecl () (HS.name n) hdl] + ["Eq", "Show"] + , instDecl ("XDR"!"XDR") n $ map (HS.InsDecl ()) + [ typeDef n + , HS.simpleFun (HS.name "xdrPut") (HS.name "_x") $ putFields (HS.var $ HS.name "_x") hdl + , HS.nameBind (HS.name "xdrGet") $ getFields (pureCon n) hdl + ] + ] where + hdl = concatMap declaration dl +definition (Definition n (TypeDef (TypeSingle (TypeUnion (UnionBody d@(Declaration dn _) cl o))))) = + [ dataDecl n + (map (\(_,(l,b)) -> + HS.RecDecl () (HS.name l) b) hcl + ++ maybe [] (\(l,b) -> [HS.RecDecl () (HS.name l) + $ HS.FieldDecl () [HS.name hom] (strictType hdt) : b]) + ho) + ["Eq", "Show"] + , HS.TypeSig () [HS.name dn] $ HS.TyFun () (HS.TyCon () $ ""!n) hdt + , HS.nameBind (HS.name dn) $ "XDR"!."xdrDiscriminant" + , instDecl ("XDR"!"XDR") n $ map (HS.InsDecl ()) + [ typeDef n + , HS.nameBind (HS.name "xdrPut") $ "XDR"!."xdrPutUnion" + , HS.nameBind (HS.name "xdrGet") $ "XDR"!."xdrGetUnion" + ] + , instDecl ("XDR"!"XDRUnion") n + [ HS.InsType () (HS.TyApp () (HS.TyCon () $ ""!"XDRDiscriminant") (HS.TyCon () $ ""!n)) hdt + , HS.InsDecl () $ HS.FunBind () $ map + (uncurry (split [] . HS.intE)) + hcl + ++ maybeToList (split + [HS.PFieldPat () (""!hom) (HS.pvar $ HS.name "d")] + (HS.app ("XDR"!."xdrFromEnum") (""!."d")) + <$> ho) + , HS.InsDecl () $ HS.FunBind () $ map (\(c,(l,b)) -> + sMatch "xdrGetUnionArm" + (HS.intP c) + $ getFields (pureCon l) b) + hcl + ++ [sMatch "xdrGetUnionArm" + (HS.pvar $ HS.name "_c") + $ maybe + (HS.app ("Prelude"!."fail") $ HS.strE $ "invalid " ++ n ++ " discriminant") + (\(l,b) -> getFields (HS.infixApp (HS.Con () $ ""!l) (HS.QVarOp () $ "Control.Applicative"!"<$>") + (HS.app ("XDR"!."xdrToEnum") $ HS.var $ HS.name "_c")) b) + ho] + ] + ] where + split p c (l,b) = sMatch "xdrSplitUnion" + (HS.PAsPat () (HS.name "_x") $ HS.PRec () (""!l) p) + $ HS.tuple [c, putFields (""!."_x") b] + hdt = declType' d + hcl = map (toInteger *** arm) cl + hom = dn ++ "'" + ho = arm <$> o + arm = unionCaseIdentifier &&& optionalDeclaration . unionDeclaration +definition (Definition n (TypeDef t)) = + [ HS.TypeDecl () (HS.DHead () $ HS.name n) $ declType' (Declaration n t) + ] +definition (Definition n (Constant v)) = + [ HS.TypeSig () [HS.name n] constantType + , HS.nameBind (HS.name n) $ HS.intE v + ] +definition (Definition n (Program t vl px)) = + [ HS.TypeSig () [HS.name n] $ HS.TyCon () $ ""!t + , HS.nameBind (HS.name n) $ HS.appFun (""!.t) $ map (\(Version _ vt rl vx) -> + HS.appFun (""!.vt) $ map (\(Procedure _ _ _ rx) -> + HS.appFun ("RPC"!."Procedure") $ map (HS.intE . toInteger) [px, vx, rx]) + rl) + vl + , dataDecl t [HS.RecDecl () (HS.name t) (map (\(Version vn vt _ _) -> + HS.FieldDecl () [HS.name vn] $ strictType $ HS.TyCon () $ ""!vt) + vl)] [] + ] ++ map (\(Version _ vt rl _) -> + dataDecl vt [HS.RecDecl () (HS.name vt) (map (\(Procedure rr rn ra _) -> + HS.FieldDecl () [HS.name rn] + $ strictType $ HS.TyApp () (HS.TyApp () (HS.TyCon () $ "RPC"!"Procedure") + $ tt $ map specType' ra) + $ maybe (HS.unit_tycon ()) specType' rr) + rl)] [] + ) vl + where + tt [] = HS.unit_tycon () + tt [a] = a + tt l = HS.TyTuple () HS.Boxed l + +hasProgramDefinition :: Specification -> Bool +hasProgramDefinition = any isProgramDefinition where + isProgramDefinition (Definition _ Program{}) = True + isProgramDefinition _ = False + +specification :: String -> Specification -> HS.Module () +specification specName specContent = + HS.Module + () + (Just $ HS.ModuleHead () (HS.ModuleName () specName) Nothing Nothing) + [HS.LanguagePragma () $ map HS.name ["DataKinds", "TypeFamilies"]] + ( [ importDecl "Prelude" Nothing + , importDecl "Control.Applicative" Nothing + , importDecl "Network.ONCRPC.XDR" $ Just $ HS.ModuleName () "XDR" + ] + ++ + [ importDecl "Network.ONCRPC.Types" $ Just $ HS.ModuleName () "RPC" + | hasProgramDefinition specContent + ] + ) + (concatMap definition specContent) + where + importDecl importModule importAs = + HS.ImportDecl + { importAnn = () + , importModule = HS.ModuleName () importModule + , importQualified = True + , importSrc = False + , importSafe = False + , importPkg = Nothing + , importAs + , importSpecs = Nothing + } + +-- |Options for generating Haskell code +data GenerateOptions = GenerateOptions + { generateModuleName :: String -- ^Name for the generated module + , generateReidentOptions :: ReidentOptions + } + deriving (Eq, Show) + +-- |Parse an XDR specification and generate a Haskell module, or fail on error. +-- The 'String' argument provides a description of the input to use in parse errors. +generateModule :: MonadFail m => GenerateOptions -> String -> BSLC.ByteString -> m (HS.Module ()) +generateModule GenerateOptions{..} n b = do + (d, s) <- either (fail . show) return $ XDR.parse n b + return $ specification generateModuleName $ reident generateReidentOptions s d + +-- |Parse an XDR specification and generate pretty-printed Haskell source string, or fail on error. +-- The 'String' argument provides a description of the input to use in parse errors. +generate :: MonadFail m => GenerateOptions -> String -> BSLC.ByteString -> m String +generate opts n s = do + m <- generateModule opts n s + return $ "-- |Generated from " ++ n ++ " by \n" + ++ prettyPrintWithMode defaultMode + { classIndent = 2 + , doIndent = 2 + , multiIfIndent = 2 + , caseIndent = 2 + , letIndent = 2 + , whereIndent = 2 + , onsideIndent = 2 + } m + +-- |'generate' from a file. +generateFromFile :: GenerateOptions -> FilePath -> IO String +generateFromFile opts f = generate opts f =<< BSLC.readFile f diff --git a/bundled/Network/ONCRPC/XDR/Opaque.hs b/bundled/Network/ONCRPC/XDR/Opaque.hs new file mode 100644 index 0000000..f21043f --- /dev/null +++ b/bundled/Network/ONCRPC/XDR/Opaque.hs @@ -0,0 +1,42 @@ +-- |Marshalling values into and out of 'Network.ONCRPC.XDR.Types.Opaque' byte strings. +-- Not really part of XDR, but convenient way to avoid many conversion functions. + +{-# LANGUAGE DefaultSignatures #-} +module Network.ONCRPC.XDR.Opaque + ( Opaqued(..) + , unopacify' + , toOpaque + , toOpaque' + , fromOpaque + , fromOpaque' + ) where + +import Data.ByteString (ByteString) + +import Network.ONCRPC.XDR.Array +import Network.ONCRPC.XDR.Serial + +-- |Values that can be stored in an 'Network.ONCRPC.XDR.Types.Opaque' 'ByteString'. +-- The default implementation allows (re-)embedding of XDR-encoded data, such as with 'RPC.Opaque_auth'. +class Opaqued a where + opacify :: a -> ByteString + default opacify :: XDR a => a -> ByteString + opacify = xdrSerialize + unopacify :: MonadFail m => ByteString -> m a + default unopacify :: (XDR a, MonadFail m) => ByteString -> m a + unopacify = either fail return . xdrDeserialize + +unopacify' :: Opaqued a => ByteString -> a +unopacify' = either error id . unopacify + +toOpaque :: (Opaqued a, KnownOrdering o, KnownNat n) => a -> Maybe (LengthArray o n ByteString) +toOpaque = lengthArray . opacify + +toOpaque' :: (Opaqued a, KnownOrdering o, KnownNat n) => a -> LengthArray o n ByteString +toOpaque' = lengthArray' . opacify + +fromOpaque :: (Opaqued a, MonadFail m) => LengthArray o n ByteString -> m a +fromOpaque = unopacify . unLengthArray + +fromOpaque' :: Opaqued a => LengthArray o n ByteString -> a +fromOpaque' = unopacify' . unLengthArray diff --git a/bundled/Network/ONCRPC/XDR/Parse.hs b/bundled/Network/ONCRPC/XDR/Parse.hs new file mode 100644 index 0000000..0b64367 --- /dev/null +++ b/bundled/Network/ONCRPC/XDR/Parse.hs @@ -0,0 +1,307 @@ +-- | XDR Parser for .x files, as per RFC4506 and RPC extensions from RFC5531 +module Network.ONCRPC.XDR.Parse + ( Binding(..) + , Scope + , parse + ) where + +import Control.Applicative ((<|>)) +import Control.Arrow (second) +import Control.Monad (void, join, liftM2) +import qualified Data.ByteString.Lazy as BSL +import Data.Char (digitToInt, isLower, isUpper, toLower, toUpper) +import Data.Functor.Identity (Identity) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, mapMaybe) +import qualified Data.Set as Set +import qualified Text.Parsec as P +import Text.Parsec (()) +import qualified Text.Parsec.Token as PT + +import qualified Network.ONCRPC.XDR.Types as XDR +import Network.ONCRPC.XDR.Specification hiding (arrayLength) + +data Binding = Binding + { bindingInitCaseConflict :: !Bool -- ^Same name as another identifier modulo first character case + , bindingDefinition :: !DefinitionBody + } + +type Scope = Map.Map String Binding +type Stream = BSL.ByteString +type Parser = P.Parsec Stream Scope + +tupleM :: Monad m => m a -> m b -> m (a, b) +tupleM = liftM2 (,) + +baseScope :: Scope +baseScope = + Map.fromList $ + ( "bool" + , Binding False $ TypeDef $ TypeSingle $ TypeEnum $ EnumBody boolValues + ) + : map (second (Binding False . TypeDef . TypeSingle)) + [ ("int", TypeInt) + , ("unsigned", TypeUnsignedInt) + , ("hyper", TypeHyper) + , ("float", TypeFloat) + , ("double", TypeDouble) + , ("quadruple", TypeQuadruple) + ] + ++ map (second $ Binding False . Constant . toInteger) boolValues + +toggleCase :: String -> String +toggleCase (c:s) + | isUpper c = toLower c:s + | isLower c = toUpper c:s +toggleCase s = s + +addScope :: Definition -> Parser () +addScope (Definition i b) = do + case b of + TypeDef t -> void $ resolveTypeDescriptor t + _ -> return () + s <- P.getState + case Map.insertLookupWithKey (const const) i (Binding (Map.member (toggleCase i) s) b) s of + (Nothing, s') -> P.putState s' + _ -> fail $ "duplicate identifier: " ++ show i + +checkInt :: (MonadFail m, Integral n) => Integer -> m n +checkInt n + | n == toInteger n' = return n' + | otherwise = fail "invalid constant" + where n' = fromInteger n + +data Value + = ValueIdentifier !String + | ValueConstant !Integer + deriving (Show) + +resolveValue :: Integral n => Value -> Parser n +resolveValue (ValueConstant n) = checkInt n +resolveValue (ValueIdentifier v) = do + s <- P.getState + case Map.lookup v s of + Just (Binding _ (Constant n)) -> checkInt n + _ -> fail $ "undefined constant: " ++ show v + +-- |Expand 'TypeSingle' 'TypeIdentifier' +resolveTypeDescriptor :: TypeDescriptor -> Parser TypeDescriptor +resolveTypeDescriptor (TypeSingle (TypeIdentifier i)) = do + s <- P.getState + case Map.lookup i s of + Just (Binding _ (TypeDef t)) -> resolveTypeDescriptor t + _ -> fail $ "undefined type: " ++ show i +resolveTypeDescriptor d = return d + +literalLetter :: Parser Char +literalLetter = P.alphaNum <|> P.char '_' + +token :: PT.GenTokenParser Stream Scope Identity +token = PT.makeTokenParser PT.LanguageDef + { PT.commentStart = "/*" + , PT.commentEnd = "*/" + , PT.commentLine = "//" + , PT.nestedComments = False + , PT.identStart = P.letter + , PT.identLetter = literalLetter + , PT.opStart = fail "token op" + , PT.opLetter = fail "token op" + , PT.reservedNames = + [ "bool" + , "case" + , "const" + , "default" + , "double" + , "quadruple" + , "enum" + , "float" + , "hyper" + , "int" + , "opaque" + , "string" + , "struct" + , "switch" + , "typedef" + , "union" + , "unsigned" + , "void" + + , "program" + , "version" + ] + , PT.reservedOpNames = [] + , PT.caseSensitive = True + } + +reserved :: String -> Parser () +reserved = PT.reserved token + +identifier :: Parser String +identifier = PT.identifier token + +endSemi1 :: Parser a -> Parser [a] +endSemi1 p = p `P.endBy1` PT.semi token + +arrayLength, variableArrayLength :: Parser ArrayLength +variableArrayLength = + VariableLength <$> PT.angles token (P.option XDR.maxLength value) +arrayLength = + FixedLength <$> PT.brackets token value + <|> variableArrayLength + +declaration :: Parser Declaration +declaration = + typeDeclaration + <|> opaqueDeclaration + <|> stringDeclaration + where + typeDeclaration = do + t <- typeSpecifier + Declaration + <$> (PT.symbol token "*" *> identifier) + <*> pure (TypeOptional t) + <|> Declaration + <$> identifier + <*> (TypeArray t <$> arrayLength <|> return (TypeSingle t)) + opaqueDeclaration = + Declaration + <$> (reserved "opaque" *> identifier) + <*> (TypeOpaque <$> arrayLength) + stringDeclaration = + Declaration + <$> (reserved "string" *> identifier) + <*> (TypeString <$> variableArrayLength) + +optionalDeclaration :: Parser OptionalDeclaration +optionalDeclaration = + Just <$> declaration + <|> Nothing <$ reserved "void" + +constant :: Parser Integer +constant = + PT.lexeme token (nat <|> P.char '-' *> (negate <$> dec)) "constant" + where + nat = P.char '0' *> (P.oneOf "xX" *> number 16 P.hexDigit <|> number 8 P.octDigit <|> return 0) <|> dec + dec = number 10 P.digit + number base digit = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 <$> P.many1 digit + +value :: Integral n => Parser n +value = resolveValue =<< + ValueConstant <$> constant + <|> ValueIdentifier <$> identifier + +typeSpecifier :: Parser TypeSpecifier +typeSpecifier = P.choice + [ TypeInt <$ reserved "int" + , TypeHyper <$ reserved "hyper" + , reserved "unsigned" *> ( + TypeUnsignedInt <$ reserved "int" + <|> TypeUnsignedHyper <$ reserved "hyper" + <|> return TypeUnsignedInt) + , TypeFloat <$ reserved "float" + , TypeDouble <$ reserved "double" + , TypeQuadruple <$ reserved "quadruple" + , TypeBool <$ reserved "bool" + , reserved "enum" *> (TypeEnum <$> enumBody <|> typeIdentifier) + , reserved "struct"*> (TypeStruct <$> structBody <|> typeIdentifier) + , reserved "union" *> (TypeUnion <$> unionBody <|> typeIdentifier) + , typeIdentifier + ] where + typeIdentifier = TypeIdentifier <$> identifier + +checkUnique :: (Ord k, Show k) => String -> [k] -> Parser (Set.Set k) +checkUnique t = ui Set.empty where + ui m [] = return m + ui m (k:l) + | Set.member k m = fail $ "duplicate " ++ t ++ ": " ++ show k + | otherwise = ui (Set.insert k m) l + +enumBody :: Parser EnumBody +enumBody = do + l <- PT.braces token $ PT.commaSep1 token $ + tupleM identifier (PT.symbol token "=" *> value) + _ <- checkUnique "enum identifier" $ fst <$> l + _ <- checkUnique "enum value" $ snd <$> l + mapM_ (\(i, v) -> addScope $ Definition i $ Constant $ toInteger v) l + return $ EnumBody l + +structBody :: Parser StructBody +structBody = do + l <- PT.braces token $ catMaybes <$> endSemi1 optionalDeclaration + _ <- checkUnique "struct member" $ declarationIdentifier <$> l + return $ StructBody l + +unionBody :: Parser UnionBody +unionBody = do + reserved "switch" + d <- PT.parens token declaration + r <- resolveTypeDescriptor $ declarationType d + p <- case r of + TypeSingle TypeInt -> return value + TypeSingle TypeUnsignedInt -> return $ fromIntegral <$> (value :: Parser XDR.UnsignedInt) + TypeSingle TypeBool -> return $ valid boolValues =<< value + TypeSingle (TypeEnum (EnumBody v)) -> return $ valid v =<< value + _ -> fail "invalid discriminant declaration" + PT.braces token $ do + l <- endSemi1 (tupleM + (P.many1 $ reserved "case" *> tupleM (P.lookAhead $ P.many1 literalLetter) p <* PT.colon token) + optionalDeclaration) + _ <- checkUnique "union member" $ mapMaybe (fmap declarationIdentifier . snd) l + _ <- checkUnique "union case" $ map snd . fst =<< l + f <- P.optionMaybe $ UnionArm "default" <$> (reserved "default" *> PT.colon token *> optionalDeclaration <* PT.semi token) + return $ UnionBody d [ (c, UnionArm s b) | (cs, b) <- l, (s, c) <- cs ] f + where + valid l n + | any ((n ==) . snd) l = return n + | otherwise = fail "invalid enum value" + +procedure :: Parser Procedure +procedure = Procedure + <$> optionalType + <*> identifier + <*> PT.parens token (catMaybes <$> PT.commaSep1 token optionalType) + <*> (PT.symbol token "=" *> value) + where + optionalType :: Parser (Maybe TypeSpecifier) + optionalType = + Just <$> typeSpecifier + <|> Nothing <$ reserved "void" + +programVersion :: Parser Version +programVersion = join Version + <$> (reserved "version" *> identifier) + <*> PT.braces token (endSemi1 procedure) + <*> (PT.symbol token "=" *> value) + +def :: Parser Definition +def = constantDef <|> typeDef <|> programDef where + constantDef = Definition + <$> (reserved "const" *> identifier) + <*> (PT.symbol token "=" *> (Constant <$> constant)) + typeDef = + reserved "typedef" *> (declDef <$> declaration) + <|> Definition <$> (reserved "enum" *> identifier) <*> (TypeDef . TypeSingle . TypeEnum <$> enumBody) + <|> Definition <$> (reserved "struct" *> identifier) <*> (TypeDef . TypeSingle . TypeStruct <$> structBody) + <|> Definition <$> (reserved "union" *> identifier) <*> (TypeDef . TypeSingle . TypeUnion <$> unionBody) + declDef (Declaration i t) = Definition i $ TypeDef t + programDef = do + reserved "program" + i <- identifier + Definition i <$> (Program i + <$> PT.braces token (endSemi1 programVersion) + <*> (PT.symbol token "=" *> value)) + +definition :: Parser Definition +definition = do + d <- def + addScope d + return d + +specification :: Parser Specification +specification = endSemi1 definition + +file :: Parser (Specification, Scope) +file = PT.whiteSpace token *> tupleM specification P.getState <* P.eof + +parse :: String -> BSL.ByteString -> Either P.ParseError (Specification, Scope) +parse = P.runParser file baseScope diff --git a/bundled/Network/ONCRPC/XDR/Reident.hs b/bundled/Network/ONCRPC/XDR/Reident.hs new file mode 100644 index 0000000..7269824 --- /dev/null +++ b/bundled/Network/ONCRPC/XDR/Reident.hs @@ -0,0 +1,108 @@ +-- |Convert XDR identifiers to Haskell identifiers. +-- Rules to convert identifiers in a 'Specification' to follow Haskell's lexical rules and ensure uniqueness for Haskell's scoping. +{-# LANGUAGE RecordWildCards #-} +module Network.ONCRPC.XDR.Reident + ( ReidentOptions(..) + , defaultReidentOptions + , reident + ) where + +import Control.Arrow (first, second) +import Data.Char (isLower, isUpper, toLower, toUpper) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Network.ONCRPC.XDR.Specification +import qualified Network.ONCRPC.XDR.Parse as XDR + +-- |How to generate Haskell identifiers from XDR in order to confirm to Haskell's lexical rules and ensure uniqueness. +data ReidentOptions = ReidentOptions + { reidentUpperPrefix, reidentLowerPrefix :: String -- ^Prefix to use to make an identifier a different case if necessary, e.g. @\"_\"@ for lower-case, or @\"XDR_\"@ for upper case (default empty: just changes the first character, possibly resulting in names like @\"nFS_NULL\"@) + , reidentJoinField, reidentJoinProcedure :: Maybe String -- ^Prefix fields with their type name (or program, version name) and this string (necessary for most XDR files), or @Nothing@ to use only the field name (or procedure name), which assumes uniqueness across the file (e.g., if you wrote the file yourself, though often safe for procedures only) (default @Just \"\'\"@) + } + deriving (Eq, Show) + +defaultReidentOptions :: ReidentOptions +defaultReidentOptions = ReidentOptions + { reidentUpperPrefix = "" + , reidentLowerPrefix = "" + , reidentJoinField = Just "'" + , reidentJoinProcedure = Just "'" + } + +data ReidentOps = ReidentOps + { reidentUpper, reidentLower :: String -> String + , reidentField, reidentProcedure :: String -> String -> String + , reidentUnique :: String -> String + } + +reidentOps :: ReidentOptions -> XDR.Scope -> ReidentOps +reidentOps ReidentOptions{..} scope = ReidentOps + { reidentUpper = toUpperPrefix reidentUpperPrefix + , reidentLower = toLowerPrefix reidentLowerPrefix + , reidentField = joinField reidentJoinField + , reidentProcedure = joinField reidentJoinProcedure + , reidentUnique = unique + } where + toUpperPrefix _ "" = error "empty upper prefix" + toUpperPrefix p s@(h:t) + | isUpper h = s + | null p = toUpper h : t + | otherwise = p ++ s + toLowerPrefix _ "" = error "empty lower prefix" + toLowerPrefix p s@(h:t) + | isLower h = s + | null p = toLower h : t + | otherwise = p ++ s + joinField (Just c) p n = p ++ c ++ n + joinField Nothing _ n = n + unique n + | Set.member n dups = n ++ "'" + | otherwise = n + dups = Map.keysSet $ Map.filter XDR.bindingInitCaseConflict scope + +declaration :: ReidentOps -> String -> Declaration -> Declaration +declaration ops n (Declaration m t) = Declaration (reidentLower ops nm) (typeDescriptor ops nm t) where + nm = reidentField ops n m + +typeSpecifier :: ReidentOps -> String -> TypeSpecifier -> TypeSpecifier +typeSpecifier ops _ (TypeEnum (EnumBody el)) = TypeEnum $ + EnumBody $ map (first $ reidentUnique ops) el +typeSpecifier ops n (TypeStruct (StructBody dl)) = TypeStruct $ + StructBody $ map (declaration ops n) dl +typeSpecifier ops n (TypeUnion (UnionBody d cl o)) = TypeUnion $ + UnionBody (decl d) (map (second arm) cl) (arm <$> o) where + arm (UnionArm l m) = UnionArm (con l) (decl <$> m) + con l = reidentUpper ops $ n ++ '\'' : l + decl = declaration ops n +typeSpecifier ops _ (TypeIdentifier i) = TypeIdentifier $ + reidentUpper ops $ reidentUnique ops i +typeSpecifier _ _ t = t + +typeDescriptor :: ReidentOps -> String -> TypeDescriptor -> TypeDescriptor +typeDescriptor ops n (TypeSingle t) = TypeSingle (typeSpecifier ops n t) +typeDescriptor ops n (TypeArray t l) = TypeArray (typeSpecifier ops n t) l +typeDescriptor ops n (TypeOptional t) = TypeOptional (typeSpecifier ops n t) +typeDescriptor _ _ t = t + +procedure :: ReidentOps -> String -> Procedure -> Procedure +procedure ops n (Procedure r m al x) = Procedure (ts <$> r) (reidentLower ops nm) (ts <$> al) x where + nm = reidentProcedure ops n m + ts = typeSpecifier ops nm + +version :: ReidentOps -> String -> Version -> Version +version ops n (Version m t pl x) = Version (reidentLower ops nm) (reidentUpper ops nt) (map (procedure ops nm) pl) x where + nm = reidentProcedure ops n m + nt = reidentProcedure ops n t + +makeDefinition :: ReidentOps -> String -> DefinitionBody -> Definition +makeDefinition ops n (TypeDef d) = Definition (reidentUpper ops n) $ TypeDef $ typeDescriptor ops n d +makeDefinition ops n (Program t vl x) = Definition (reidentLower ops n) $ Program (reidentUpper ops t) (map (version ops n) vl) x +makeDefinition ops n b@(Constant _) = Definition (reidentLower ops n) b + +definition :: ReidentOps -> Definition -> Definition +definition ops (Definition n d) = makeDefinition ops (reidentUnique ops n) d + +reident :: ReidentOptions -> XDR.Scope -> Specification -> Specification +reident o = map . definition . reidentOps o + diff --git a/bundled/Network/ONCRPC/XDR/Serial.hs b/bundled/Network/ONCRPC/XDR/Serial.hs new file mode 100644 index 0000000..75ca17b --- /dev/null +++ b/bundled/Network/ONCRPC/XDR/Serial.hs @@ -0,0 +1,291 @@ +{-# OPTIONS -Wno-orphans #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} + +-- | XDR Serialization +module Network.ONCRPC.XDR.Serial ( + XDR (..), + XDREnum (..), + xdrToEnum', + xdrPutEnum, + xdrGetEnum, + XDRUnion (..), + xdrDiscriminant, + xdrPutUnion, + xdrGetUnion, + xdrSerialize, + xdrSerializeLazy, + xdrDeserialize, + xdrDeserializeLazy, +) where + +import Control.Monad (guard, replicateM, unless) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.Maybe (fromJust, listToMaybe) +import Data.Proxy (Proxy (Proxy)) +import Data.Serialize (Get, Put) +import Data.Serialize qualified as Serialize +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import GHC.TypeLits (natVal) +import Network.ONCRPC.XDR.Types qualified as XDR + +import Network.ONCRPC.XDR.Array + +instance MonadFail (Either String) where + fail = Left + +-- | An XDR type that can be (de)serialized. +class XDR a where + -- | XDR identifier/type descriptor; argument value is ignored. + xdrType :: a -> String + + xdrPut :: a -> Put + + xdrGet :: Get a + +instance XDR XDR.Int where + xdrType _ = "int" + xdrPut = Serialize.putInt32be + xdrGet = Serialize.getInt32be + +instance XDR XDR.UnsignedInt where + xdrType _ = "unsigned int" + xdrPut = Serialize.putWord32be + xdrGet = Serialize.getWord32be + +instance XDR XDR.Hyper where + xdrType _ = "hyper" + xdrPut = Serialize.putInt64be + xdrGet = Serialize.getInt64be + +instance XDR XDR.UnsignedHyper where + xdrType _ = "unsigned hyper" + xdrPut = Serialize.putWord64be + xdrGet = Serialize.getWord64be + +instance XDR XDR.Float where + xdrType _ = "float" + xdrPut = Serialize.putFloat32be + xdrGet = Serialize.getFloat32be + +instance XDR XDR.Double where + xdrType _ = "double" + xdrPut = Serialize.putFloat64be + xdrGet = Serialize.getFloat64be + +instance XDR XDR.Bool where + xdrType _ = "bool" + xdrPut = xdrPutEnum + xdrGet = xdrGetEnum + +{- | An XDR type defined with \"enum\". + Note that the 'XDREnum' 'XDR.Int' value is not (necessarily) the same as the 'Enum' 'Int' value. + The 'Enum' instance is derived automatically to allow 'succ', etc. to work usefully in Haskell, whereas the 'XDREnum' reflects the XDR-defined values. +-} +class (XDR a, Enum a) => XDREnum a where + xdrFromEnum :: a -> XDR.Int + xdrToEnum :: (MonadFail m) => XDR.Int -> m a + +instance XDREnum XDR.Int where + xdrFromEnum = id + xdrToEnum = pure + +instance XDREnum XDR.UnsignedInt where + xdrFromEnum = fromIntegral + xdrToEnum = pure . fromIntegral + +-- | Version of 'xdrToEnum' that fails at runtime for invalid values: @fromMaybe undefined . 'xdrToEnum'@. +xdrToEnum' :: (XDREnum a) => XDR.Int -> a +xdrToEnum' = either error id . xdrToEnum + +-- | Default implementation of 'xdrPut' for 'XDREnum'. +xdrPutEnum :: (XDREnum a) => a -> Put +xdrPutEnum = Serialize.put . xdrFromEnum + +-- | Default implementation of 'xdrGet' for 'XDREnum'. +xdrGetEnum :: (XDREnum a) => Get a +xdrGetEnum = xdrToEnum =<< Serialize.get + +instance XDREnum XDR.Bool where + xdrFromEnum False = 0 + xdrFromEnum True = 1 + xdrToEnum 0 = pure False + xdrToEnum 1 = pure True + xdrToEnum _ = fail "invalid bool" + +-- | An XDR type defined with \"union\" +class (XDR a, XDREnum (XDRDiscriminant a)) => XDRUnion a where + type XDRDiscriminant a + + -- | Split a union into its discriminant and body generator. + xdrSplitUnion :: a -> (XDR.Int, Put) + + -- | Get the body of a union based on its discriminant. + xdrGetUnionArm :: XDR.Int -> Get a + +xdrDiscriminant :: (XDRUnion a) => a -> XDRDiscriminant a +xdrDiscriminant = xdrToEnum' . fst . xdrSplitUnion + +-- | Default implementation of 'xdrPut' for 'XDRUnion'. +xdrPutUnion :: (XDRUnion a) => a -> Put +xdrPutUnion = uncurry ((>>) . xdrPut) . xdrSplitUnion + +-- | Default implementation of 'xdrGet' for 'XDRUnion'. +xdrGetUnion :: (XDRUnion a) => Get a +xdrGetUnion = xdrGet >>= xdrGetUnionArm + +instance (XDR a) => XDR (XDR.Optional a) where + xdrType = ('*' :) . xdrType . fromJust + xdrPut = xdrPutUnion + xdrGet = xdrGetUnion + +instance (XDR a) => XDRUnion (XDR.Optional a) where + type XDRDiscriminant (XDR.Optional a) = XDR.Bool + xdrSplitUnion Nothing = (0, pure ()) + xdrSplitUnion (Just a) = (1, xdrPut a) + xdrGetUnionArm 0 = pure Nothing + xdrGetUnionArm 1 = Just <$> xdrGet + xdrGetUnionArm d = fail $ "xdrGetUnion: invalid discriminant for " ++ xdrType (undefined :: XDR.Optional a) ++ ": " ++ show d + +xdrPutPad :: XDR.Length -> Put +xdrPutPad n = case n `mod` 4 of + 0 -> pure () + 1 -> Serialize.putWord16host 0 >> Serialize.putWord8 0 + 2 -> Serialize.putWord16host 0 + _ {- must be 3 -} -> Serialize.putWord8 0 + +xdrGetPad :: XDR.Length -> Get () +xdrGetPad n = case n `mod` 4 of + 0 -> pure () + 1 -> do + 0 <- Serialize.getWord16host + 0 <- Serialize.getWord8 + pure () + 2 -> do + 0 <- Serialize.getWord16host + pure () + _ {- must be 3 -} -> do + 0 <- Serialize.getWord8 + pure () + +bsLength :: BS.ByteString -> XDR.Length +bsLength = fromIntegral . BS.length + +xdrPutByteString :: XDR.Length -> BS.ByteString -> Put +xdrPutByteString l b = do + unless (bsLength b == l) $ error "xdrPutByteString: incorrect length" + Serialize.putByteString b + xdrPutPad l + +xdrGetByteString :: XDR.Length -> Get BS.ByteString +xdrGetByteString l = do + b <- Serialize.getByteString $ fromIntegral l + xdrGetPad l + pure b + +fixedLength :: forall n a. (KnownNat n) => LengthArray 'EQ n a -> String -> String +fixedLength a = (++ ('[' : show (fixedLengthArrayLength a) ++ "]")) + +variableLength :: forall n a. (KnownNat n) => LengthArray 'LT n a -> String -> String +variableLength a + | n == XDR.maxLength = (++ "<>") + | otherwise = (++ ('<' : show n ++ ">")) + where + n = fromIntegral $ boundedLengthArrayBound a + +xdrGetBoundedArray :: forall n a. (KnownNat n) => (XDR.Length -> Get a) -> Get (LengthArray 'LT n a) +xdrGetBoundedArray g = do + l <- xdrGet + guard $ l <= fromIntegral (boundedLengthArrayBound (undefined :: LengthArray 'LT n a)) + unsafeLengthArray <$> g l + +instance (KnownNat n, XDR a) => XDR (LengthArray 'EQ n [a]) where + xdrType la = + fixedLength la $ xdrType $ fromJust $ listToMaybe $ unLengthArray la + xdrPut la = mapM_ xdrPut a where a = unLengthArray la + xdrGet = + unsafeLengthArray <$> replicateM (fromInteger $ natVal $ Proxy @n) xdrGet + +instance (KnownNat n, XDR a) => XDR (LengthArray 'LT n [a]) where + xdrType la = + variableLength la $ xdrType $ fromJust $ listToMaybe $ unLengthArray la + xdrPut la = do + xdrPut (fromIntegral (length a) :: XDR.Length) + mapM_ xdrPut a + where + a = unLengthArray la + xdrGet = xdrGetBoundedArray $ \l -> replicateM (fromIntegral l) xdrGet + +instance (KnownNat n, XDR a) => XDR (LengthArray 'EQ n (Vector a)) where + xdrType la = fixedLength la $ xdrType $ Vector.head $ unLengthArray la + xdrPut la = mapM_ xdrPut a where a = unLengthArray la + xdrGet = + unsafeLengthArray + <$> Vector.replicateM (fromInteger $ natVal $ Proxy @n) xdrGet + +instance (KnownNat n, XDR a) => XDR (LengthArray 'LT n (Vector a)) where + xdrType la = variableLength la $ xdrType $ Vector.head $ unLengthArray la + xdrPut la = do + xdrPut (fromIntegral (length a) :: XDR.Length) + mapM_ xdrPut a + where + a = unLengthArray la + xdrGet = xdrGetBoundedArray $ \l -> Vector.replicateM (fromIntegral l) xdrGet + +instance (KnownNat n) => XDR (LengthArray 'EQ n BS.ByteString) where + xdrType o = fixedLength o "opaque" + xdrPut o = + xdrPutByteString (fromInteger $ natVal $ Proxy @n) $ unLengthArray o + xdrGet = + unsafeLengthArray <$> xdrGetByteString (fromInteger $ natVal $ Proxy @n) + +instance (KnownNat n) => XDR (LengthArray 'LT n BS.ByteString) where + xdrType o = variableLength o "opaque" + xdrPut o = do + xdrPut l + xdrPutByteString l b + where + l = bsLength b + b = unLengthArray o + xdrGet = xdrGetBoundedArray xdrGetByteString + +instance XDR () where + xdrType () = "void" + xdrPut () = pure () + xdrGet = pure () + +instance (XDR a, XDR b) => XDR (a, b) where + xdrType (a, b) = xdrType a ++ '+' : xdrType b + xdrPut (a, b) = xdrPut a >> xdrPut b + xdrGet = (,) <$> xdrGet <*> xdrGet + +instance (XDR a, XDR b, XDR c) => XDR (a, b, c) where + xdrType (a, b, c) = xdrType a ++ '+' : xdrType b ++ '+' : xdrType c + xdrPut (a, b, c) = xdrPut a >> xdrPut b >> xdrPut c + xdrGet = (,,) <$> xdrGet <*> xdrGet <*> xdrGet + +instance (XDR a, XDR b, XDR c, XDR d) => XDR (a, b, c, d) where + xdrType (a, b, c, d) = xdrType a ++ '+' : xdrType b ++ '+' : xdrType c ++ '+' : xdrType d + xdrPut (a, b, c, d) = xdrPut a >> xdrPut b >> xdrPut c >> xdrPut d + xdrGet = (,,,) <$> xdrGet <*> xdrGet <*> xdrGet <*> xdrGet + +xdrSerialize :: (XDR a) => a -> BS.ByteString +xdrSerialize = Serialize.runPut . xdrPut + +xdrSerializeLazy :: (XDR a) => a -> BSL.ByteString +xdrSerializeLazy = Serialize.runPutLazy . xdrPut + +-- | @"S.runGet' 'xdrGet'@ +xdrDeserialize :: (XDR a) => BS.ByteString -> Either String a +xdrDeserialize = Serialize.runGet xdrGet + +-- | @"S.runGetLazy' 'xdrGet'@ +xdrDeserializeLazy :: (XDR a) => BSL.ByteString -> Either String a +xdrDeserializeLazy = Serialize.runGetLazy xdrGet diff --git a/bundled/Network/ONCRPC/XDR/Specification.hs b/bundled/Network/ONCRPC/XDR/Specification.hs new file mode 100644 index 0000000..efcaa76 --- /dev/null +++ b/bundled/Network/ONCRPC/XDR/Specification.hs @@ -0,0 +1,111 @@ +-- |XDR specification, as per RFC4506 and RPC extensions from RFC5531 + +module Network.ONCRPC.XDR.Specification + where + +import qualified Network.ONCRPC.XDR.Types as XDR +import Data.Word (Word32) + +type ProgNum = Word32 +type VersNum = Word32 +type ProcNum = Word32 + +data ArrayLength + = FixedLength { arrayLength :: !XDR.Length } + | VariableLength { arrayLength :: !XDR.Length -- ^defaulted to maxLength + } + +data TypeDescriptor + = TypeSingle + { descriptorType :: !TypeSpecifier + } + | TypeArray + { descriptorType :: !TypeSpecifier + , descriptorLength :: !ArrayLength + } + | TypeOpaque + { descriptorLength :: !ArrayLength + } + | TypeString + { descriptorLength :: !ArrayLength -- ^only 'VariableArray' + } + | TypeOptional + { descriptorType :: !TypeSpecifier + } + +data TypeSpecifier + = TypeInt + | TypeUnsignedInt + | TypeHyper + | TypeUnsignedHyper + | TypeFloat + | TypeDouble + | TypeQuadruple + | TypeBool + | TypeEnum !EnumBody + | TypeStruct !StructBody + | TypeUnion !UnionBody + | TypeIdentifier !String + +-- |Non-void declaration +data Declaration = Declaration + { declarationIdentifier :: !String + , declarationType :: TypeDescriptor + } + +-- |'Declaration' or void +type OptionalDeclaration = Maybe Declaration + +type EnumValues = [(String, XDR.Int)] + +newtype EnumBody = EnumBody + { enumValues :: EnumValues + } + +boolValues :: EnumValues +boolValues = [("FALSE", 0), ("TRUE", 1)] + +newtype StructBody = StructBody + { structMembers :: [Declaration] -- ^with voids elided + } + +data UnionArm = UnionArm + { unionCaseIdentifier :: String -- ^The literal string found after "case", for labeling + , unionDeclaration :: OptionalDeclaration + } + +data UnionBody = UnionBody + { unionDiscriminant :: !Declaration + , unionCases :: [(XDR.Int, UnionArm)] + , unionDefault :: Maybe UnionArm + } + +data Procedure = Procedure + { procedureRes :: Maybe TypeSpecifier + , procedureIdentifier :: !String + , procedureArgs :: [TypeSpecifier] + , procedureNumber :: !ProcNum + } + +data Version = Version + { versionIdentifier :: !String + , versionTypeIdentifier :: !String + , versionProcedures :: [Procedure] + , versionNumber :: !VersNum + } + +data DefinitionBody + = TypeDef TypeDescriptor + | Constant Integer + | Program + { programTypeIdentifier :: !String + , programVersions :: [Version] + , programNumber :: !ProgNum + } + +data Definition = Definition + { definitionIdentifier :: !String + , definitionBody :: !DefinitionBody + } + +type Specification = [Definition] diff --git a/bundled/Network/ONCRPC/XDR/Types.hs b/bundled/Network/ONCRPC/XDR/Types.hs new file mode 100644 index 0000000..dc89952 --- /dev/null +++ b/bundled/Network/ONCRPC/XDR/Types.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} + +-- | XDR Types. +-- The 'Quadruple' type is not supported as there is no reasonable Haskell equivalent. +-- +-- This module should be imported qualified, e.g., as @XDR@. +module Network.ONCRPC.XDR.Types + ( Int + , UnsignedInt + , Hyper + , UnsignedHyper + , Float + , Double + , Bool + , FixedArray + , Array + , FixedOpaque + , Opaque + , FixedString + , String + , Optional + + , Length + , maxLength + ) + where + +import Prelude hiding (Int, String) + +import Data.ByteString (ByteString) +import Data.Int (Int32, Int64) +import Data.Vector (Vector) +import Data.Word (Word32, Word64) + +import Network.ONCRPC.XDR.Array + +type Int = Int32 +type UnsignedInt = Word32 +type Hyper = Int64 +type UnsignedHyper = Word64 +type FixedArray n a = FixedLengthArray n (Vector a) +type Array n a = BoundedLengthArray n (Vector a) +type FixedOpaque n = FixedLengthArray n ByteString +type Opaque n = BoundedLengthArray n ByteString +type FixedString n = FixedLengthArray n ByteString +type String n = BoundedLengthArray n ByteString +type Optional a = Maybe a + +-- |Not a real XDR type, but used for length headers +type Length = UnsignedInt + +maxLength :: Length +maxLength = maxBound diff --git a/bundled/Network/Stellar/Asset.hs b/bundled/Network/Stellar/Asset.hs new file mode 100644 index 0000000..8a6b7b3 --- /dev/null +++ b/bundled/Network/Stellar/Asset.hs @@ -0,0 +1,43 @@ +module Network.Stellar.Asset + ( Asset(..) + , toXdrAsset + , toXdrAsset' + ) +where + +import Control.Monad ((<=<)) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Network.ONCRPC.XDR +import Network.Stellar.Keypair +import qualified Network.Stellar.TransactionXdr as X + +data Asset = AssetNative + | AssetAlphaNum4 { assetCode :: T.Text, assetIssuer :: T.Text } + | AssetAlphaNum12 { assetCode :: T.Text, assetIssuer :: T.Text } + +toXdrAsset :: Asset -> Maybe X.Asset +toXdrAsset AssetNative = Just X.Asset'ASSET_TYPE_NATIVE +toXdrAsset (AssetAlphaNum4 code issuer) = + X.Asset'ASSET_TYPE_CREDIT_ALPHANUM4 + <$> (X.AlphaNum4 <$> lengthArray (encodeUtf8 code) <*> toXdrAccount issuer) +toXdrAsset (AssetAlphaNum12 code issuer) = + X.Asset'ASSET_TYPE_CREDIT_ALPHANUM12 + <$> (X.AlphaNum12 <$> lengthArray (encodeUtf8 code) <*> toXdrAccount issuer) + +toXdrAsset' :: Asset -> X.Asset +toXdrAsset' AssetNative = X.Asset'ASSET_TYPE_NATIVE +toXdrAsset' (AssetAlphaNum4 code issuer) = + X.Asset'ASSET_TYPE_CREDIT_ALPHANUM4 $ + X.AlphaNum4 (lengthArray' $ encodeUtf8 code) (toXdrAccount' issuer) +toXdrAsset' (AssetAlphaNum12 code issuer) = + X.Asset'ASSET_TYPE_CREDIT_ALPHANUM12 $ + X.AlphaNum12 (lengthArray' $ encodeUtf8 code) (toXdrAccount' issuer) + +toXdrAccount :: T.Text -> Maybe X.AccountID +toXdrAccount = + fmap X.PublicKey'PUBLIC_KEY_TYPE_ED25519 . lengthArray <=< decodePublic + +toXdrAccount' :: T.Text -> X.AccountID +toXdrAccount' = + X.PublicKey'PUBLIC_KEY_TYPE_ED25519 . lengthArray' . decodePublic' diff --git a/bundled/Network/Stellar/Builder.hs b/bundled/Network/Stellar/Builder.hs new file mode 100644 index 0000000..ce1acd7 --- /dev/null +++ b/bundled/Network/Stellar/Builder.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DataKinds #-} + +module Network.Stellar.Builder + ( TransactionBuilder(..) + , transactionBuilder + , addOperation + , setTimeBounds + , buildWithFee + , build + , toEnvelope + , viewAccount + ) +where + +import qualified Crypto.Sign.Ed25519 as C +import Data.Maybe (fromMaybe) +import Data.Word (Word64) + +import Network.ONCRPC.XDR.Array (boundLengthArrayFromList, + emptyBoundedLengthArray, + lengthArray', unLengthArray) +import Network.Stellar.TransactionXdr + +baseFee :: Uint32 +baseFee = 100 + +data TransactionBuilder = TransactionBuilder + { tbSourceAccount :: C.PublicKey + , tbSequenceNumber :: SequenceNumber + , tbTimeBounds :: Maybe TimeBounds + , tbMemo :: Maybe Memo + , tbOperations :: [Operation] + } + +viewAccount :: AccountID -> C.PublicKey +viewAccount (PublicKey'PUBLIC_KEY_TYPE_ED25519 key) = + C.PublicKey $ unLengthArray key + +transactionBuilder :: C.PublicKey -> SequenceNumber -> TransactionBuilder +transactionBuilder acc seqNum = TransactionBuilder acc seqNum Nothing Nothing [] + +addOperation :: TransactionBuilder -> Operation -> TransactionBuilder +addOperation tb op = tb{ tbOperations = tbOperations tb ++ [op] } + +setTimeBounds :: TransactionBuilder -> Word64 -> Word64 -> TransactionBuilder +setTimeBounds tb mintime maxtime = tb{ tbTimeBounds = Just $ TimeBounds mintime maxtime } + +buildWithFee :: Uint32 -> TransactionBuilder -> TransactionV0 +buildWithFee fee (TransactionBuilder acc seqNum bounds memo ops) = + TransactionV0 + (buildAccount acc) + (fee * fromIntegral (length ops)) + seqNum + bounds + mm + (boundLengthArrayFromList ops) + 0 + where + mm = fromMaybe Memo'MEMO_NONE memo + buildAccount (C.PublicKey key) = lengthArray' key + +build :: TransactionBuilder -> TransactionV0 +build = buildWithFee baseFee + +toEnvelope :: TransactionV0 -> TransactionEnvelope +toEnvelope tx = + TransactionEnvelope'ENVELOPE_TYPE_TX_V0 $ + TransactionV0Envelope tx emptyBoundedLengthArray diff --git a/bundled/Network/Stellar/Horizon.hs b/bundled/Network/Stellar/Horizon.hs new file mode 100644 index 0000000..0709465 --- /dev/null +++ b/bundled/Network/Stellar/Horizon.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} + +module Network.Stellar.Horizon + ( HorizonServer + , publicHorizon + , testHorizon + , httpServer + , httpsServer + ) +where + +import Data.Text +import Network.HTTP.Req (Url, Scheme(..), http, https) + +type HorizonServer (scheme :: Scheme) = Url scheme + +publicHorizon :: HorizonServer 'Https +publicHorizon = httpsServer "horizon.stellar.org" + +testHorizon :: HorizonServer 'Https +testHorizon = httpsServer "horizon-testnet.stellar.org" + +httpServer :: Text -> HorizonServer 'Http +httpServer = http + +httpsServer :: Text -> HorizonServer 'Https +httpsServer = https diff --git a/bundled/Network/Stellar/Keypair.hs b/bundled/Network/Stellar/Keypair.hs new file mode 100644 index 0000000..0daf697 --- /dev/null +++ b/bundled/Network/Stellar/Keypair.hs @@ -0,0 +1,125 @@ +module Network.Stellar.Keypair + ( KeyPair(..) + , PublicKey(..) + , EncodingVersion(..) + , fromPrivateKey + , fromPrivateKey' + , signatureHint + , encodePublic + , encodePublicKey + , decodePublic + , decodePublicKey + , decodePublic' + , decodePublicKey' + , encodePrivate + , decodePrivate + , decodePrivate' + , encodeKey + )where + +import Control.Monad (guard) +import Crypto.Random (getSystemDRG, randomBytesGenerate) +import Crypto.Sign.Ed25519 +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Base32 (decodeBase32, encodeBase32) +import Data.Maybe (fromJust, fromMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding (encodeUtf8) +import Data.Word (Word16, Word8) +import GHC.Stack (HasCallStack) + +data KeyPair = KeyPair + { kpPublicKey :: PublicKey + , kpPrivateKey :: SecretKey + , kpSeed :: ByteString + } + +instance Show KeyPair where + show (KeyPair public _ seed) = + "KeyPair {" ++ Text.unpack (encodePublic $ unPublicKey public) ++ ", " + ++ Text.unpack (encodePrivate seed) ++ "}" + +fromSeed :: ByteString -> KeyPair +fromSeed seed = KeyPair public private seed + where (public, private) = fromJust $ createKeypairFromSeed_ seed + +fromPrivateKey :: Text -> Maybe KeyPair +fromPrivateKey = fmap fromSeed . decodePrivate + +fromPrivateKey' :: HasCallStack => Text -> KeyPair +fromPrivateKey' = fromSeed . decodePrivate' + +signatureHint :: KeyPair -> ByteString +signatureHint = BS.drop 28 . unPublicKey . kpPublicKey + + +encodePublic :: ByteString -> Text +encodePublic = encodeKey EncodingAccount + +encodePublicKey :: PublicKey -> Text +encodePublicKey = encodePublic . unPublicKey + +encodePrivate :: ByteString -> Text +encodePrivate = encodeKey EncodingSeed + +decodePublic :: Text -> Maybe ByteString +decodePublic = decodeKey EncodingAccount + +decodePublicKey :: Text -> Maybe PublicKey +decodePublicKey = fmap PublicKey . decodeKey EncodingAccount + +decodePublic' :: Text -> ByteString +decodePublic' = decodeKey' EncodingAccount + +decodePublicKey' :: Text -> PublicKey +decodePublicKey' = PublicKey . decodePublic' + +decodePrivate :: Text -> Maybe ByteString +decodePrivate = decodeKey EncodingSeed + +decodePrivate' :: HasCallStack => Text -> ByteString +decodePrivate' = decodeKey' EncodingSeed + +decodeKey :: EncodingVersion -> Text -> Maybe ByteString +decodeKey version key = do + keyBlob <- either (const Nothing) Just $ decodeBase32 $ encodeUtf8 key + let (payload, checksum) = BS.splitAt (BS.length keyBlob - 2) keyBlob + (versionByte, keyData) <- BS.uncons payload + let versionCheck = versionByte == versionByteName version + checksumCheck = crc16XmodemLE payload == checksum + guard (versionCheck && checksumCheck) + pure keyData + +decodeKey' :: HasCallStack => EncodingVersion -> Text -> ByteString +decodeKey' version key = + fromMaybe (error $ "Decoding key failed " ++ Text.unpack key) $ + decodeKey version key + +data EncodingVersion = EncodingAccount | EncodingSeed | EncodingPreAuthTx | EncodingSha256Hash + +versionByteName :: EncodingVersion -> Word8 +versionByteName EncodingAccount = 48 +versionByteName EncodingSeed = 144 +versionByteName EncodingPreAuthTx = 152 +versionByteName EncodingSha256Hash = 184 + +encodeKey :: EncodingVersion -> ByteString -> Text +encodeKey version key = encodeBase32 $ payload <> checksum + where + versionByte = versionByteName version + payload = versionByte `BS.cons` key + checksum = crc16XmodemLE payload + +crc16XmodemLE :: ByteString -> ByteString +crc16XmodemLE bs = BS.pack [fromIntegral $ checksum .&. 0xFF, fromIntegral $ checksum `shiftR` 8] + where checksum = BS.foldl crcRound 0 bs + +crcRound :: Word16 -> Word8 -> Word16 +crcRound crc byte = crc2 + where + code = (crc `shiftR` 8) `xor` fromIntegral byte + code2 = code `xor` (code `shiftR` 4) + crc2 = (crc `shiftL` 8) `xor` code2 `xor` (code2 `shiftL` 5) `xor` (code2 `shiftL` 12) diff --git a/bundled/Network/Stellar/Network.hs b/bundled/Network/Stellar/Network.hs new file mode 100644 index 0000000..2510890 --- /dev/null +++ b/bundled/Network/Stellar/Network.hs @@ -0,0 +1,25 @@ +module Network.Stellar.Network + ( Network + , publicNetwork + , testNetwork + ) +where + +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as LB +import Data.Digest.Pure.SHA (sha256, bytestringDigest) + +type Network = B.ByteString + +hashPassphrase :: String -> Network +hashPassphrase = LB.toStrict . bytestringDigest . sha256 . LB.fromStrict . B.pack + +publicPassphrase :: String +publicPassphrase = "Public Global Stellar Network ; September 2015" +publicNetwork :: Network +publicNetwork = hashPassphrase publicPassphrase + +testPassphrase :: String +testPassphrase = "Test SDF Network ; September 2015" +testNetwork :: Network +testNetwork = hashPassphrase testPassphrase diff --git a/bundled/Network/Stellar/Operation.hs b/bundled/Network/Stellar/Operation.hs new file mode 100644 index 0000000..655e7b4 --- /dev/null +++ b/bundled/Network/Stellar/Operation.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DataKinds #-} + +module Network.Stellar.Operation + ( makeCreateAccountOperation + , makePaymentOperation + , makeNativePaymentOperation + , makeChangeTrustOperation + , makeAllowTrustOperation + , makeAccountMergeOperation + , makeInflationOperation + , makeManageDataOperation + ) +where + +-- import qualified Crypto.Sign.Ed25519 as C +-- import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +-- import qualified Data.Word (Word8) +import Network.Stellar.TransactionXdr +import qualified Network.ONCRPC.XDR as XDR + +makeOperationGeneric2 + :: (a -> OperationBody) -> (c -> b -> a) -> c -> b -> Operation +makeOperationGeneric2 opBodyCons opCons a1 = + Operation Nothing . opBodyCons . opCons a1 + +makeOperationGeneric3 + :: (a -> OperationBody) -> (d -> c -> b -> a) -> d -> c -> b -> Operation +makeOperationGeneric3 opBodyCons opCons a1 a2 = + Operation Nothing . opBodyCons . opCons a1 a2 + +makeAssetIdentifier + :: (XDR.FixedOpaque 4 -> a) -> (XDR.FixedOpaque 12 -> a) -> String -> a +makeAssetIdentifier shortCons longCons assetname + | length assetname <= 4 = + shortCons $ XDR.padLengthArray (BC.pack assetname) 0 + | length assetname <= 12 = + longCons $ XDR.padLengthArray (BC.pack assetname) 0 + | otherwise = + error $ "Name of asset " ++ assetname ++ " is too long." + + +makeCreateAccountOperation :: AccountID -> Int64 -> Operation +makeCreateAccountOperation destination amount = Operation Nothing $ OperationBody'CREATE_ACCOUNT $ CreateAccountOp destination amount + +makePaymentOperation :: MuxedAccount -> Asset -> Int64 -> Operation +makePaymentOperation = makeOperationGeneric3 OperationBody'PAYMENT PaymentOp + +makeNativePaymentOperation :: MuxedAccount -> Int64 -> Operation +makeNativePaymentOperation destination = + makePaymentOperation destination Asset'ASSET_TYPE_NATIVE + +makeChangeTrustOperation :: Asset -> Int64 -> Operation +makeChangeTrustOperation = makeOperationGeneric2 OperationBody'CHANGE_TRUST ChangeTrustOp + +makeAllowTrustOperation :: AccountID -> String -> Bool -> Operation +makeAllowTrustOperation trustor asset = + makeOperationGeneric3 OperationBody'ALLOW_TRUST AllowTrustOp trustor + (makeAssetIdentifier + AllowTrustOpAsset'ASSET_TYPE_CREDIT_ALPHANUM4 + AllowTrustOpAsset'ASSET_TYPE_CREDIT_ALPHANUM12 + asset) + +makeAccountMergeOperation :: MuxedAccount -> Operation +makeAccountMergeOperation = Operation Nothing . OperationBody'ACCOUNT_MERGE + +makeInflationOperation :: Operation +makeInflationOperation = Operation Nothing OperationBody'INFLATION + +makeManageDataOperation :: String -> Maybe String -> Operation +makeManageDataOperation name value = + makeOperationGeneric2 OperationBody'MANAGE_DATA ManageDataOp (XDR.boundLengthArray $ BC.pack name) ((XDR.boundLengthArray.BC.pack) `fmap` value) diff --git a/bundled/Network/Stellar/Query.hs b/bundled/Network/Stellar/Query.hs new file mode 100644 index 0000000..74ecd16 --- /dev/null +++ b/bundled/Network/Stellar/Query.hs @@ -0,0 +1,213 @@ +{-# OPTIONS -Wno-orphans #-} -- MonandHttp IO + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} + +module Network.Stellar.Query where + +import Prelude hiding (lookup) + +import Control.Exception (throwIO) +import qualified Crypto.Sign.Ed25519 as C +import Data.Aeson (Value(Object, String), FromJSON) +import Data.Aeson.KeyMap (lookup) +import qualified Data.ByteString.Base64 as B64 +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Word (Word64) +import Network.HTTP.Req +import qualified Network.ONCRPC.XDR as XDR +import Network.Stellar.Asset +import Network.Stellar.Horizon +import Network.Stellar.Keypair +import qualified Network.Stellar.TransactionXdr as TX + +instance MonadHttp IO where + handleHttpException = throwIO + +query :: (FromJSON a) => HorizonServer scheme -> [T.Text] -> IO a +query server pathSegments = queryWithParams server pathSegments [] + +queryWithParams :: (FromJSON a) => HorizonServer scheme -> [T.Text] -> [(T.Text, T.Text)] -> IO a +queryWithParams server pathSegments params = do + response <- req GET (foldl (/:) server pathSegments) NoReqBody jsonResponse $ foldMap (uncurry (=:)) params + return $ responseBody response + +postWithBody :: (FromJSON a) => HorizonServer scheme -> [T.Text] -> (T.Text, T.Text) -> IO a +postWithBody server pathSegments (q,value) = do + response <- req POST (foldl (/:) server pathSegments) (ReqBodyUrlEnc $ q =: value) jsonResponse mempty + return $ responseBody response + +getSequenceNumber :: HorizonServer scheme -> C.PublicKey -> IO TX.SequenceNumber +getSequenceNumber server acc = do + response <- query server ["accounts", encodePublic $ C.unPublicKey acc] + case response of + Object hm -> + case lookup "sequence" hm of + Just (String s) -> + pure $ fromIntegral (read $ T.unpack s :: Integer) + Just x -> fail $ "Value is not a number " ++ show x + Nothing -> fail "No sequence in account" + _ -> fail $ "Sequence number response is not an object " ++ show response + +submitTransaction :: HorizonServer scheme -> TX.TransactionEnvelope -> IO TX.TransactionResult +submitTransaction server tx = do + response <- + postWithBody + server + ["transactions"] + ("tx", decodeUtf8 $ B64.encode $ XDR.xdrSerialize tx) + case response of + Object hm -> + case lookup "result_xdr" hm of + Just (String t) -> + either fail pure $ + XDR.xdrDeserialize =<< B64.decode (encodeUtf8 t) + Just x -> fail $ "Value is not a string " ++ show x + Nothing -> fail "No result_xdr in transaction" + _ -> fail $ "Transaction response is not an object " ++ show response + +type HorizonQuery = ([T.Text], [(T.Text, T.Text)]) +runQuery :: HorizonServer scheme -> HorizonQuery -> IO Value +runQuery server (pathSegments, params) = queryWithParams server pathSegments params + + +-- data CallBuilder (baseSegment :: [T.Text] -> [T.Text]) = CallBuilder { otherPathSegments :: [T.Text] } +-- instance Monoid (CallBuilder baseSegment) where +-- mempty = +-- newtype EffectsCallBuilder = CallBuilder (++["effects"]) deriving Monoid + +-- buildQuery :: CallBuilder baseSegment -> T.Text +-- buildQuery () + + +-- Queries related to accounts + +getAccount :: C.PublicKey -> HorizonQuery +getAccount account = + (["accounts", encodePublic $ C.unPublicKey account], []) + +getAccountData :: C.PublicKey -> T.Text -> HorizonQuery +getAccountData account key = + (["accounts", encodePublic $ C.unPublicKey account, "data", key], []) + +getAccountX :: T.Text -> C.PublicKey -> [(T.Text, T.Text)] -> HorizonQuery +getAccountX x account params = + (["accounts", encodePublic $ C.unPublicKey account, x], params) + +getAccountEffects :: C.PublicKey -> [(T.Text, T.Text)] -> HorizonQuery +getAccountEffects = getAccountX "effects" + +getAccountOffers :: C.PublicKey -> [(T.Text, T.Text)] -> HorizonQuery +getAccountOffers = getAccountX "offers" + +getAccountOperations :: C.PublicKey -> [(T.Text, T.Text)] -> HorizonQuery +getAccountOperations = getAccountX "operations" + +getAccountPayments :: C.PublicKey -> [(T.Text, T.Text)] -> HorizonQuery +getAccountPayments = getAccountX "payments" + +getAccountTransactions :: C.PublicKey -> [(T.Text, T.Text)] -> HorizonQuery +getAccountTransactions = getAccountX "transactions" + +-- optional parameters: asset_code, asset_issuer +getAssets :: [(T.Text, T.Text)] -> HorizonQuery +getAssets params = + (["assets"], params) + +getEffects :: [(T.Text, T.Text)] -> HorizonQuery +getEffects params = + (["effects"], params) + +-- Queries related to ledgers + +getAllLedgers :: [(T.Text, T.Text)] -> HorizonQuery +getAllLedgers params = (["ledgers"], params) + +getLedger :: T.Text -> HorizonQuery +getLedger ledgerId = (["ledgers", ledgerId], []) + +getLedgerX :: T.Text -> T.Text -> [(T.Text, T.Text)] -> HorizonQuery +getLedgerX x ledger params = (["ledgers", ledger, x], params) + +getLedgerEffects :: T.Text -> [(T.Text, T.Text)] -> HorizonQuery +getLedgerEffects = getLedgerX "effects" + +getLedgerOperations :: T.Text -> [(T.Text, T.Text)] -> HorizonQuery +getLedgerOperations = getLedgerX "operations" + +getLedgerPayments :: T.Text -> [(T.Text, T.Text)] -> HorizonQuery +getLedgerPayments = getLedgerX "payments" + +getLedgerTransactions :: T.Text -> [(T.Text, T.Text)] -> HorizonQuery +getLedgerTransactions = getLedgerX "transactions" + +-- Queries related to operations + +getAllOperations :: [(T.Text, T.Text)] -> HorizonQuery +getAllOperations params = (["operations"], params) + +getOperation :: T.Text -> HorizonQuery +getOperation op = (["operations", op], []) + +getOperationEffects :: T.Text -> [(T.Text, T.Text)] -> HorizonQuery +getOperationEffects op params = (["operations", op, "effects"], params) + +-- Queries related to transactions + +getAllTransactions :: [(T.Text, T.Text)] -> HorizonQuery +getAllTransactions params = (["transactions"], params) + +getTransaction :: T.Text -> HorizonQuery +getTransaction tx = (["transactions", tx], []) + +getTransactionX :: T.Text -> T.Text -> [(T.Text, T.Text)] -> HorizonQuery +getTransactionX x tx params = (["transactions", tx, x], params) + +getTransactionEffects :: T.Text -> [(T.Text, T.Text)] -> HorizonQuery +getTransactionEffects = getTransactionX "effects" + +getTransactionOperations :: T.Text -> [(T.Text, T.Text)] -> HorizonQuery +getTransactionOperations = getTransactionX "operations" + +getTransactionPayments :: T.Text -> [(T.Text, T.Text)] -> HorizonQuery +getTransactionPayments = getTransactionX "payments" + + +-- Queries related to trading + +assetToParams :: T.Text -> Asset -> [(T.Text, T.Text)] +assetToParams prefix AssetNative = [(prefix `T.append` "_asset_type", "native")] +assetToParams prefix (AssetAlphaNum4 assetcode issuer) = + [(prefix `T.append` "_asset_type", "credit_alphanum4"), (prefix `T.append` "_asset_code", assetcode), (prefix `T.append` "_asset_issuer", issuer)] +assetToParams prefix (AssetAlphaNum12 assetcode issuer) = + [(prefix `T.append` "_asset_type", "credit_alphanum12"), (prefix `T.append` "_asset_code", assetcode), (prefix `T.append` "_asset_issuer", issuer)] + +getOrderBook :: Asset -> Asset -> HorizonQuery +getOrderBook selling buying = + ( ["order_book"] + , assetToParams "selling" selling ++ assetToParams "buying" buying + ) + +getPaymentPaths :: C.PublicKey -> C.PublicKey -> Asset -> Word64 -> HorizonQuery +getPaymentPaths sourceAccount destAccount asset amount = + ( ["paths"] + , ("source_account", encodePublic $ C.unPublicKey sourceAccount) + : ("destination_account", encodePublic $ C.unPublicKey destAccount) + : ("destination_amount", T.pack $ show amount) + : assetToParams "destination" asset + ) + +getTradeAggregations :: Asset -> Asset -> Word64 -> Word64 -> Word64 -> [(T.Text, T.Text)] -> HorizonQuery +getTradeAggregations base counter start end resolution params = + (["trade_aggregations"], + assetToParams "base" base + ++ assetToParams "counter" counter + ++ ("start_time", T.pack $ show start) + : ("end_time", T.pack $ show end) + : ("resolution", T.pack $ show resolution) + : params) + +getTrades :: Maybe Asset -> Maybe Asset -> Maybe T.Text -> [(T.Text, T.Text)] -> HorizonQuery +getTrades base counter offerId params = + (["trades"], concat [maybe [] (assetToParams "base") base, maybe [] (assetToParams "counter") counter, maybe [] (\x -> [("offer_id", x)]) offerId, params]) diff --git a/bundled/Network/Stellar/Signature.hs b/bundled/Network/Stellar/Signature.hs new file mode 100644 index 0000000..07aebe0 --- /dev/null +++ b/bundled/Network/Stellar/Signature.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Network.Stellar.Signature + ( signBlob + , verifyBlob + , verifyBlobWithKP + , signTx + , verifyTx + , transactionHash + ) +where + +import qualified Crypto.Sign.Ed25519 as C +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import Data.Digest.Pure.SHA (bytestringDigest, sha256) +import qualified Data.Vector as Vector + +import Network.ONCRPC.XDR (xdrSerialize) +import qualified Network.ONCRPC.XDR as XDR +import Network.ONCRPC.XDR.Array (boundLengthArray, lengthArray', + unLengthArray, unsafeLengthArray) +import Network.Stellar.Keypair +import Network.Stellar.Network +import Network.Stellar.TransactionXdr + +signBlob :: KeyPair -> ByteString -> ByteString +signBlob KeyPair{kpPrivateKey} = C.unSignature . C.dsign kpPrivateKey + +verifyBlob + :: C.PublicKey + -> ByteString -- ^ message + -> ByteString -- ^ signature + -> Bool +verifyBlob publicKey message = C.dverify publicKey message . C.Signature + +verifyBlobWithKP + :: KeyPair + -> ByteString -- ^ message + -> ByteString -- ^ signature + -> Bool +verifyBlobWithKP KeyPair{kpPublicKey} message = + C.dverify kpPublicKey message . C.Signature + +data SignError = TooManySignatures + deriving Show + +takeEnd :: Int -> ByteString -> ByteString +takeEnd n bs = B.drop (B.length bs - n) bs + +accountXdrFromEd :: C.PublicKey -> AccountID +accountXdrFromEd (C.PublicKey key) = + PublicKey'PUBLIC_KEY_TYPE_ED25519 $ lengthArray' key + +keyToHint :: KeyPair -> SignatureHint +keyToHint KeyPair{kpPublicKey} = + lengthArray' $ takeEnd 4 $ xdrSerialize $ accountXdrFromEd kpPublicKey + +signTx + :: Network + -> TransactionEnvelope + -> [KeyPair] + -> Either SignError TransactionEnvelope +signTx nId envelope newKeys = + case envelope of + TransactionEnvelope'ENVELOPE_TYPE_TX_V0 + (TransactionV0Envelope tx signatures) -> + TransactionEnvelope'ENVELOPE_TYPE_TX_V0 . TransactionV0Envelope tx + <$> appendSignatures signatures + TransactionEnvelope'ENVELOPE_TYPE_TX + (TransactionV1Envelope tx signatures) -> + TransactionEnvelope'ENVELOPE_TYPE_TX . TransactionV1Envelope tx + <$> appendSignatures signatures + TransactionEnvelope'ENVELOPE_TYPE_TX_FEE_BUMP + (FeeBumpTransactionEnvelope tx signatures) -> + TransactionEnvelope'ENVELOPE_TYPE_TX_FEE_BUMP + . FeeBumpTransactionEnvelope tx + <$> appendSignatures signatures + where + signature :: KeyPair -> Signature + signature KeyPair{kpPrivateKey} = + boundLengthArray $ + C.unSignature $ C.dsign kpPrivateKey $ transactionHash nId envelope + + appendSignatures + :: XDR.Array 20 DecoratedSignature + -> Either SignError (XDR.Array 20 DecoratedSignature) + appendSignatures oldSignatures + | Vector.length oldSignatures' + length newKeys <= 20 = + Right $ + unsafeLengthArray $ + oldSignatures' + <> Vector.fromList + [ DecoratedSignature (keyToHint key) (signature key) + | key <- newKeys + ] + | otherwise = Left TooManySignatures + where + oldSignatures' = unLengthArray oldSignatures + +transactionHash :: Network -> TransactionEnvelope -> ByteString +transactionHash nId = \case + TransactionEnvelope'ENVELOPE_TYPE_TX_V0 (TransactionV0Envelope tx _) -> + go ( xdrSerialize ENVELOPE_TYPE_TX + <> xdrSerialize PUBLIC_KEY_TYPE_ED25519 + ) + tx + TransactionEnvelope'ENVELOPE_TYPE_TX (TransactionV1Envelope tx _) -> + go (xdrSerialize ENVELOPE_TYPE_TX) tx + TransactionEnvelope'ENVELOPE_TYPE_TX_FEE_BUMP + (FeeBumpTransactionEnvelope tx _) -> + go (xdrSerialize ENVELOPE_TYPE_TX_FEE_BUMP) tx + where + go prefix tx = + LB.toStrict $ + bytestringDigest $ + sha256 $ + LB.fromStrict $ + B.concat [nId, prefix, xdrSerialize tx] + +verifyTx + :: Network + -> TransactionEnvelope + -> C.PublicKey + -> DecoratedSignature + -> Bool +verifyTx nId envelope publicKey (DecoratedSignature _ signature) = + C.dverify + publicKey + (transactionHash nId envelope) + (C.Signature $ unLengthArray signature) diff --git a/bundled/Network/Stellar/Stellar-transaction.x b/bundled/Network/Stellar/Stellar-transaction.x new file mode 100644 index 0000000..fdb2b5f --- /dev/null +++ b/bundled/Network/Stellar/Stellar-transaction.x @@ -0,0 +1,2067 @@ +// Copyright 2015 Stellar Development Foundation and contributors. Licensed +// under the Apache License, Version 2.0. See the COPYING file at the root +// of this distribution or at http://www.apache.org/licenses/LICENSE-2.0 + + +typedef opaque Hash[32]; +typedef opaque uint256[32]; + +typedef unsigned int uint32; +typedef int int32; + +typedef unsigned hyper uint64; +typedef hyper int64; + +enum CryptoKeyType +{ + KEY_TYPE_ED25519 = 0, + KEY_TYPE_PRE_AUTH_TX = 1, + KEY_TYPE_HASH_X = 2, + KEY_TYPE_ED25519_SIGNED_PAYLOAD = 3, + // MUXED enum values for supported type are derived from the enum values + // above by ORing them with 0x100 + KEY_TYPE_MUXED_ED25519 = 0x100 +}; + +enum PublicKeyType +{ + PUBLIC_KEY_TYPE_ED25519 = KEY_TYPE_ED25519 +}; + +// Source or destination of a payment operation +union MuxedAccount switch (CryptoKeyType type) +{ +case KEY_TYPE_ED25519: + uint256 ed25519; +case KEY_TYPE_MUXED_ED25519: + struct + { + uint64 id; + uint256 ed25519; + } med25519; +}; + +enum SignerKeyType +{ + SIGNER_KEY_TYPE_ED25519 = KEY_TYPE_ED25519, + SIGNER_KEY_TYPE_PRE_AUTH_TX = KEY_TYPE_PRE_AUTH_TX, + SIGNER_KEY_TYPE_HASH_X = KEY_TYPE_HASH_X +}; + +union PublicKey switch (PublicKeyType type) +{ +case PUBLIC_KEY_TYPE_ED25519: + uint256 ed25519; +}; + +union SignerKey switch (SignerKeyType type) +{ +case SIGNER_KEY_TYPE_ED25519: + uint256 ed25519; +case SIGNER_KEY_TYPE_PRE_AUTH_TX: + /* Hash of Transaction structure */ + uint256 preAuthTx; +case SIGNER_KEY_TYPE_HASH_X: + /* Hash of random 256 bit preimage X */ + uint256 hashX; +}; + +// variable size as the size depends on the signature scheme used +typedef opaque Signature<64>; + +typedef opaque SignatureHint[4]; + +typedef PublicKey NodeID; + +struct Curve25519Secret +{ + opaque key[32]; +}; + +struct Curve25519Public +{ + opaque key[32]; +}; + +struct HmacSha256Key +{ + opaque key[32]; +}; + +struct HmacSha256Mac +{ + opaque mac[32]; +}; + + +// Copyright 2015 Stellar Development Foundation and contributors. Licensed +// under the Apache License, Version 2.0. See the COPYING file at the root +// of this distribution or at http://www.apache.org/licenses/LICENSE-2.0 + +//%#include "xdr/Stellar-types.h" + +typedef PublicKey AccountID; +typedef opaque Thresholds[4]; +typedef string string32<32>; +typedef string string64<64>; +typedef int64 SequenceNumber; +typedef uint64 TimePoint; +typedef uint64 Duration; +typedef opaque DataValue<64>; +typedef Hash PoolID; // SHA256(LiquidityPoolParameters) + +// 1-4 alphanumeric characters right-padded with 0 bytes +typedef opaque AssetCode4[4]; + +// 5-12 alphanumeric characters right-padded with 0 bytes +typedef opaque AssetCode12[12]; + +enum AssetType +{ + ASSET_TYPE_NATIVE = 0, + ASSET_TYPE_CREDIT_ALPHANUM4 = 1, + ASSET_TYPE_CREDIT_ALPHANUM12 = 2, + ASSET_TYPE_POOL_SHARE = 3 +}; + +union AssetCode switch (AssetType type) +{ +case ASSET_TYPE_CREDIT_ALPHANUM4: + AssetCode4 assetCode4; + +case ASSET_TYPE_CREDIT_ALPHANUM12: + AssetCode12 assetCode12; + + // add other asset types here in the future +}; + +struct AlphaNum4 +{ + AssetCode4 assetCode; + AccountID issuer; +}; + +struct AlphaNum12 +{ + AssetCode12 assetCode; + AccountID issuer; +}; + +union Asset switch (AssetType type) +{ +case ASSET_TYPE_NATIVE: // Not credit + void; + +case ASSET_TYPE_CREDIT_ALPHANUM4: + AlphaNum4 alphaNum4; + +case ASSET_TYPE_CREDIT_ALPHANUM12: + AlphaNum12 alphaNum12; + + // add other asset types here in the future +}; + +// price in fractional representation +struct Price +{ + int32 n; // numerator + int32 d; // denominator +}; + +// the 'Thresholds' type is packed uint8_t values +// defined by these indexes +enum ThresholdIndexes +{ + THRESHOLD_MASTER_WEIGHT = 0, + THRESHOLD_LOW = 1, + THRESHOLD_MED = 2, + THRESHOLD_HIGH = 3 +}; + +enum LedgerEntryType +{ + ACCOUNT = 0, + TRUSTLINE = 1, + OFFER = 2, + DATA = 3, + CLAIMABLE_BALANCE = 4, + LIQUIDITY_POOL = 5 +}; + +struct Signer +{ + SignerKey key; + uint32 weight; // really only need 1byte +}; + +enum AccountFlags +{ // masks for each flag + + // Flags set on issuer accounts + // TrustLines are created with authorized set to "false" requiring + // the issuer to set it for each TrustLine + AUTH_REQUIRED_FLAG = 0x1, + // If set, the authorized flag in TrustLines can be cleared + // otherwise, authorization cannot be revoked + AUTH_REVOCABLE_FLAG = 0x2, + // Once set, causes all AUTH_* flags to be read-only + AUTH_IMMUTABLE_FLAG = 0x4 +}; + +/* AccountEntry + + Main entry representing a user in Stellar. All transactions are + performed using an account. + + Other ledger entries created require an account. + +*/ + +struct AccountEntry +{ + AccountID accountID; // master public key for this account + int64 balance; // in stroops + SequenceNumber seqNum; // last sequence number used for this account + uint32 numSubEntries; // number of sub-entries this account has + // drives the reserve + AccountID* inflationDest; // Account to vote for during inflation + uint32 flags; // see AccountFlags + + string32 homeDomain; // can be used for reverse federation and memo lookup + + // fields used for signatures + // thresholds stores unsigned bytes: [weight of master|low|medium|high] + Thresholds thresholds; + + Signer signers<20>; // possible signers for this account + + // reserved for future use + void; +}; + +/* TrustLineEntry + A trust line represents a specific trust relationship with + a credit/issuer (limit, authorization) + as well as the balance. +*/ + +enum TrustLineFlags +{ + // issuer has authorized account to perform transactions with its credit + AUTHORIZED_FLAG = 1 +}; + +union TrustLineAsset switch (AssetType type) +{ +case ASSET_TYPE_NATIVE: // Not credit + void; + +case ASSET_TYPE_CREDIT_ALPHANUM4: + AlphaNum4 alphaNum4; + +case ASSET_TYPE_CREDIT_ALPHANUM12: + AlphaNum12 alphaNum12; + +case ASSET_TYPE_POOL_SHARE: + PoolID liquidityPoolID; + + // add other asset types here in the future +}; + +struct TrustLineEntry +{ + AccountID accountID; // account this trustline belongs to + Asset asset; // type of asset (with issuer) + int64 balance; // how much of this asset the user has. + // Asset defines the unit for this; + + int64 limit; // balance cannot be above this + uint32 flags; // see TrustLineFlags + + // reserved for future use + void; +}; + +enum OfferEntryFlags +{ + // issuer has authorized account to perform transactions with its credit + PASSIVE_FLAG = 1 +}; + +/* OfferEntry + An offer is the building block of the offer book, they are automatically + claimed by payments when the price set by the owner is met. + + For example an Offer is selling 10A where 1A is priced at 1.5B + +*/ +struct OfferEntry +{ + AccountID sellerID; + uint64 offerID; + Asset selling; // A + Asset buying; // B + int64 amount; // amount of A + + /* price for this offer: + price of A in terms of B + price=AmountB/AmountA=priceNumerator/priceDenominator + price is after fees + */ + Price price; + uint32 flags; // see OfferEntryFlags + + // reserved for future use + void; +}; + +/* DataEntry + Data can be attached to accounts. +*/ +struct DataEntry +{ + AccountID accountID; // account this data belongs to + string64 dataName; + DataValue dataValue; + + // reserved for future use + void; +}; + +enum ClaimPredicateType +{ + CLAIM_PREDICATE_UNCONDITIONAL = 0, + CLAIM_PREDICATE_AND = 1, + CLAIM_PREDICATE_OR = 2, + CLAIM_PREDICATE_NOT = 3, + CLAIM_PREDICATE_BEFORE_ABSOLUTE_TIME = 4, + CLAIM_PREDICATE_BEFORE_RELATIVE_TIME = 5 +}; + +union ClaimPredicate switch (ClaimPredicateType type) +{ +case CLAIM_PREDICATE_UNCONDITIONAL: + void; +case CLAIM_PREDICATE_AND: + ClaimPredicate andPredicates<2>; +case CLAIM_PREDICATE_OR: + ClaimPredicate orPredicates<2>; +case CLAIM_PREDICATE_NOT: + ClaimPredicate* notPredicate; +case CLAIM_PREDICATE_BEFORE_ABSOLUTE_TIME: + int64 absBefore; // Predicate will be true if closeTime < absBefore +case CLAIM_PREDICATE_BEFORE_RELATIVE_TIME: + int64 relBefore; // Seconds since closeTime of the ledger in which the + // ClaimableBalanceEntry was created +}; + +enum ClaimantType +{ + CLAIMANT_TYPE_V0 = 0 +}; + +union Claimant switch (ClaimantType type) +{ +case CLAIMANT_TYPE_V0: + struct + { + AccountID destination; // The account that can use this condition + ClaimPredicate predicate; // Claimable if predicate is true + } v0; +}; + +enum ClaimableBalanceIDType +{ + CLAIMABLE_BALANCE_ID_TYPE_V0 = 0 +}; + +union ClaimableBalanceID switch (ClaimableBalanceIDType type) +{ +case CLAIMABLE_BALANCE_ID_TYPE_V0: + Hash v0; +}; + +union LedgerEntryData switch (LedgerEntryType type) +{ +case ACCOUNT: + AccountEntry account; +case TRUSTLINE: + TrustLineEntry trustLine; +case OFFER: + OfferEntry offer; +case DATA: + DataEntry data; +}; + +struct LedgerEntry +{ + uint32 lastModifiedLedgerSeq; // ledger the LedgerEntry was last changed + + LedgerEntryData data; + + // reserved for future use + void; +}; + +union LedgerKey switch (LedgerEntryType type) +{ +case ACCOUNT: + struct + { + AccountID accountID; + } account; + +case TRUSTLINE: + struct + { + AccountID accountID; + TrustLineAsset asset; + } trustLine; + +case OFFER: + struct + { + AccountID sellerID; + int64 offerID; + } offer; + +case DATA: + struct + { + AccountID accountID; + string64 dataName; + } data; + +case CLAIMABLE_BALANCE: + struct + { + ClaimableBalanceID balanceID; + } claimableBalance; + +case LIQUIDITY_POOL: + struct + { + PoolID liquidityPoolID; + } liquidityPool; +}; + +// list of all envelope types used in the application +// those are prefixes used when building signatures for +// the respective envelopes +enum EnvelopeType +{ + ENVELOPE_TYPE_TX_V0 = 0, + ENVELOPE_TYPE_SCP = 1, + ENVELOPE_TYPE_TX = 2, + ENVELOPE_TYPE_AUTH = 3, + ENVELOPE_TYPE_SCPVALUE = 4, + ENVELOPE_TYPE_TX_FEE_BUMP = 5, + ENVELOPE_TYPE_OP_ID = 6, + ENVELOPE_TYPE_POOL_REVOKE_OP_ID = 7 +}; + +// Copyright 2015 Stellar Development Foundation and contributors. Licensed +// under the Apache License, Version 2.0. See the COPYING file at the root +// of this distribution or at http://www.apache.org/licenses/LICENSE-2.0 + +//%#include "xdr/Stellar-ledger-entries.h" + +struct DecoratedSignature +{ + SignatureHint hint; // last 4 bytes of the public key, used as a hint + Signature signature; // actual signature +}; + +enum OperationType +{ + CREATE_ACCOUNT = 0, + PAYMENT = 1, + PATH_PAYMENT_STRICT_RECEIVE = 2, + MANAGE_SELL_OFFER = 3, + CREATE_PASSIVE_SELL_OFFER = 4, + SET_OPTIONS = 5, + CHANGE_TRUST = 6, + ALLOW_TRUST = 7, + ACCOUNT_MERGE = 8, + INFLATION = 9, + MANAGE_DATA = 10, + BUMP_SEQUENCE = 11, + MANAGE_BUY_OFFER = 12, + PATH_PAYMENT_STRICT_SEND = 13, + CREATE_CLAIMABLE_BALANCE = 14, + CLAIM_CLAIMABLE_BALANCE = 15, + BEGIN_SPONSORING_FUTURE_RESERVES = 16, + END_SPONSORING_FUTURE_RESERVES = 17, + REVOKE_SPONSORSHIP = 18, + CLAWBACK = 19, + CLAWBACK_CLAIMABLE_BALANCE = 20, + SET_TRUST_LINE_FLAGS = 21, + LIQUIDITY_POOL_DEPOSIT = 22, + LIQUIDITY_POOL_WITHDRAW = 23 +}; + +/* CreateAccount +Creates and funds a new account with the specified starting balance. + +Threshold: med + +Result: CreateAccountResult + +*/ +struct CreateAccountOp +{ + AccountID destination; // account to create + int64 startingBalance; // amount they end up with +}; + +/* Payment + + Send an amount in specified asset to a destination account. + + Threshold: med + + Result: PaymentResult +*/ +struct PaymentOp +{ + MuxedAccount destination; // recipient of the payment + Asset asset; // what they end up with + int64 amount; // amount they end up with +}; + +/* PathPaymentStrictReceive + +send an amount to a destination account through a path. +(up to sendMax, sendAsset) +(X0, Path[0]) .. (Xn, Path[n]) +(destAmount, destAsset) + +Threshold: med + +Result: PathPaymentStrictReceiveResult +*/ +struct PathPaymentStrictReceiveOp +{ + Asset sendAsset; // asset we pay with + int64 sendMax; // the maximum amount of sendAsset to + // send (excluding fees). + // The operation will fail if can't be met + + MuxedAccount destination; // recipient of the payment + Asset destAsset; // what they end up with + int64 destAmount; // amount they end up with + + Asset path<5>; // additional hops it must go through to get there +}; + +/* PathPaymentStrictSend + +send an amount to a destination account through a path. +(sendMax, sendAsset) +(X0, Path[0]) .. (Xn, Path[n]) +(at least destAmount, destAsset) + +Threshold: med + +Result: PathPaymentStrictSendResult +*/ +struct PathPaymentStrictSendOp +{ + Asset sendAsset; // asset we pay with + int64 sendAmount; // amount of sendAsset to send (excluding fees) + + MuxedAccount destination; // recipient of the payment + Asset destAsset; // what they end up with + int64 destMin; // the minimum amount of dest asset to + // be received + // The operation will fail if it can't be met + + Asset path<5>; // additional hops it must go through to get there +}; + +/* Creates, updates or deletes an offer + +Threshold: med + +Result: ManageSellOfferResult + +*/ +struct ManageSellOfferOp +{ + Asset selling; + Asset buying; + int64 amount; // amount being sold. if set to 0, delete the offer + Price price; // price of thing being sold in terms of what you are buying + + // 0=create a new offer, otherwise edit an existing offer + int64 offerID; +}; + +/* Creates, updates or deletes an offer with amount in terms of buying asset + +Threshold: med + +Result: ManageBuyOfferResult + +*/ +struct ManageBuyOfferOp +{ + Asset selling; + Asset buying; + int64 buyAmount; // amount being bought. if set to 0, delete the offer + Price price; // price of thing being bought in terms of what you are + // selling + + // 0=create a new offer, otherwise edit an existing offer + int64 offerID; +}; + +/* Creates an offer that doesn't take offers of the same price + +Threshold: med + +Result: CreatePassiveSellOfferResult + +*/ +struct CreatePassiveSellOfferOp +{ + Asset selling; // A + Asset buying; // B + int64 amount; // amount taker gets + Price price; // cost of A in terms of B +}; + +/* Set Account Options + + updates "AccountEntry" fields. + note: updating thresholds or signers requires high threshold + + Threshold: med or high + + Result: SetOptionsResult +*/ +struct SetOptionsOp +{ + AccountID* inflationDest; // sets the inflation destination + + uint32* clearFlags; // which flags to clear + uint32* setFlags; // which flags to set + + // account threshold manipulation + uint32* masterWeight; // weight of the master account + uint32* lowThreshold; + uint32* medThreshold; + uint32* highThreshold; + + string32* homeDomain; // sets the home domain + + // Add, update or remove a signer for the account + // signer is deleted if the weight is 0 + Signer* signer; +}; + +/* Creates, updates or deletes a trust line + + Threshold: med + + Result: ChangeTrustResult + +*/ +struct ChangeTrustOp +{ + Asset line; + + // if limit is set to 0, deletes the trust line + int64 limit; +}; + +/* Updates the "authorized" flag of an existing trust line + this is called by the issuer of the related asset. + + note that authorize can only be set (and not cleared) if + the issuer account does not have the AUTH_REVOCABLE_FLAG set + Threshold: low + + Result: AllowTrustResult +*/ +union AllowTrustOpAsset switch (AssetType type) +{ + // ASSET_TYPE_NATIVE is not allowed + case ASSET_TYPE_CREDIT_ALPHANUM4: + opaque assetCode4[4]; + + case ASSET_TYPE_CREDIT_ALPHANUM12: + opaque assetCode12[12]; + + // add other asset types here in the future +}; + +struct AllowTrustOp +{ + AccountID trustor; + + AllowTrustOpAsset asset; + + bool authorize; +}; + +/* Inflation + Runs inflation + +Threshold: low + +Result: InflationResult + +*/ + +/* AccountMerge + Transfers native balance to destination account. + + Threshold: high + + Result : AccountMergeResult +*/ + +/* ManageData + Adds, Updates, or Deletes a key value pair associated with a particular + account. + + Threshold: med + + Result: ManageDataResult +*/ +struct ManageDataOp +{ + string64 dataName; + DataValue* dataValue; // set to null to clear +}; + +/* Bump Sequence + + increases the sequence to a given level + + Threshold: low + + Result: BumpSequenceResult +*/ +struct BumpSequenceOp +{ + SequenceNumber bumpTo; +}; + +/* Creates a claimable balance entry + + Threshold: med + + Result: CreateClaimableBalanceResult +*/ +struct CreateClaimableBalanceOp +{ + Asset asset; + int64 amount; + Claimant claimants<10>; +}; + +/* Claims a claimable balance entry + + Threshold: low + + Result: ClaimClaimableBalanceResult +*/ +struct ClaimClaimableBalanceOp +{ + ClaimableBalanceID balanceID; +}; + +/* BeginSponsoringFutureReserves + + Establishes the is-sponsoring-future-reserves-for relationship between + the source account and sponsoredID + + Threshold: med + + Result: BeginSponsoringFutureReservesResult +*/ +struct BeginSponsoringFutureReservesOp +{ + AccountID sponsoredID; +}; + +/* EndSponsoringFutureReserves + + Terminates the current is-sponsoring-future-reserves-for relationship in + which source account is sponsored + + Threshold: med + + Result: EndSponsoringFutureReservesResult +*/ +// EndSponsoringFutureReserves is empty + +/* RevokeSponsorship + + If source account is not sponsored or is sponsored by the owner of the + specified entry or sub-entry, then attempt to revoke the sponsorship. + If source account is sponsored, then attempt to transfer the sponsorship + to the sponsor of source account. + + Threshold: med + + Result: RevokeSponsorshipResult +*/ +enum RevokeSponsorshipType +{ + REVOKE_SPONSORSHIP_LEDGER_ENTRY = 0, + REVOKE_SPONSORSHIP_SIGNER = 1 +}; + +union RevokeSponsorshipOp switch (RevokeSponsorshipType type) +{ +case REVOKE_SPONSORSHIP_LEDGER_ENTRY: + LedgerKey ledgerKey; +case REVOKE_SPONSORSHIP_SIGNER: + struct + { + AccountID accountID; + SignerKey signerKey; + } signer; +}; + +/* Claws back an amount of an asset from an account + + Threshold: med + + Result: ClawbackResult +*/ +struct ClawbackOp +{ + Asset asset; + MuxedAccount from; + int64 amount; +}; + +/* Claws back a claimable balance + + Threshold: med + + Result: ClawbackClaimableBalanceResult +*/ +struct ClawbackClaimableBalanceOp +{ + ClaimableBalanceID balanceID; +}; + +/* SetTrustLineFlagsOp + + Updates the flags of an existing trust line. + This is called by the issuer of the related asset. + + Threshold: low + + Result: SetTrustLineFlagsResult +*/ +struct SetTrustLineFlagsOp +{ + AccountID trustor; + Asset asset; + + uint32 clearFlags; // which flags to clear + uint32 setFlags; // which flags to set +}; + +const LIQUIDITY_POOL_FEE_V18 = 30; + +/* Deposit assets into a liquidity pool + + Threshold: med + + Result: LiquidityPoolDepositResult +*/ +struct LiquidityPoolDepositOp +{ + PoolID liquidityPoolID; + int64 maxAmountA; // maximum amount of first asset to deposit + int64 maxAmountB; // maximum amount of second asset to deposit + Price minPrice; // minimum depositA/depositB + Price maxPrice; // maximum depositA/depositB +}; + +/* Withdraw assets from a liquidity pool + + Threshold: med + + Result: LiquidityPoolWithdrawResult +*/ +struct LiquidityPoolWithdrawOp +{ + PoolID liquidityPoolID; + int64 amount; // amount of pool shares to withdraw + int64 minAmountA; // minimum amount of first asset to withdraw + int64 minAmountB; // minimum amount of second asset to withdraw +}; + +/* An operation is the lowest unit of work that a transaction does */ +union OperationBody switch (OperationType type) +{ + case CREATE_ACCOUNT: + CreateAccountOp createAccountOp; + case PAYMENT: + PaymentOp paymentOp; + case PATH_PAYMENT_STRICT_RECEIVE: + PathPaymentStrictReceiveOp pathPaymentStrictReceiveOp; + case MANAGE_SELL_OFFER: + ManageSellOfferOp manageSellOfferOp; + case CREATE_PASSIVE_SELL_OFFER: + CreatePassiveSellOfferOp createPassiveSellOfferOp; + case SET_OPTIONS: + SetOptionsOp setOptionsOp; + case CHANGE_TRUST: + ChangeTrustOp changeTrustOp; + case ALLOW_TRUST: + AllowTrustOp allowTrustOp; + case ACCOUNT_MERGE: + MuxedAccount destination; + case INFLATION: + void; + case MANAGE_DATA: + ManageDataOp manageDataOp; + case BUMP_SEQUENCE: + BumpSequenceOp bumpSequenceOp; + case MANAGE_BUY_OFFER: + ManageBuyOfferOp manageBuyOfferOp; + case PATH_PAYMENT_STRICT_SEND: + PathPaymentStrictSendOp pathPaymentStrictSendOp; + case CREATE_CLAIMABLE_BALANCE: + CreateClaimableBalanceOp createClaimableBalanceOp; + case CLAIM_CLAIMABLE_BALANCE: + ClaimClaimableBalanceOp claimClaimableBalanceOp; + case BEGIN_SPONSORING_FUTURE_RESERVES: + BeginSponsoringFutureReservesOp beginSponsoringFutureReservesOp; + case END_SPONSORING_FUTURE_RESERVES: + void; + case REVOKE_SPONSORSHIP: + RevokeSponsorshipOp revokeSponsorshipOp; + case CLAWBACK: + ClawbackOp clawbackOp; + case CLAWBACK_CLAIMABLE_BALANCE: + ClawbackClaimableBalanceOp clawbackClaimableBalanceOp; + case SET_TRUST_LINE_FLAGS: + SetTrustLineFlagsOp setTrustLineFlagsOp; + case LIQUIDITY_POOL_DEPOSIT: + LiquidityPoolDepositOp liquidityPoolDepositOp; + case LIQUIDITY_POOL_WITHDRAW: + LiquidityPoolWithdrawOp liquidityPoolWithdrawOp; +}; +struct Operation +{ + // sourceAccount is the account used to run the operation + // if not set, the runtime defaults to "sourceAccount" specified at + // the transaction level + AccountID* sourceAccount; + + OperationBody body; +}; + +enum MemoType +{ + MEMO_NONE = 0, + MEMO_TEXT = 1, + MEMO_ID = 2, + MEMO_HASH = 3, + MEMO_RETURN = 4 +}; + +union Memo switch (MemoType type) +{ +case MEMO_NONE: + void; +case MEMO_TEXT: + string text<28>; +case MEMO_ID: + uint64 id; +case MEMO_HASH: + Hash hash; // the hash of what to pull from the content server +case MEMO_RETURN: + Hash retHash; // the hash of the tx you are rejecting +}; + +struct TimeBounds +{ + TimePoint minTime; + TimePoint maxTime; // 0 here means no maxTime +}; + +struct LedgerBounds +{ + uint32 minLedger; + uint32 maxLedger; // 0 here means no maxLedger +}; + +struct PreconditionsV2 +{ + TimeBounds* timeBounds; + + // Transaction only valid for ledger numbers n such that + // minLedger <= n < maxLedger (if maxLedger == 0, then + // only minLedger is checked) + LedgerBounds* ledgerBounds; + + // If NULL, only valid when sourceAccount's sequence number + // is seqNum - 1. Otherwise, valid when sourceAccount's + // sequence number n satisfies minSeqNum <= n < tx.seqNum. + // Note that after execution the account's sequence number + // is always raised to tx.seqNum, and a transaction is not + // valid if tx.seqNum is too high to ensure replay protection. + SequenceNumber* minSeqNum; + + // For the transaction to be valid, the current ledger time must + // be at least minSeqAge greater than sourceAccount's seqTime. + Duration minSeqAge; + + // For the transaction to be valid, the current ledger number + // must be at least minSeqLedgerGap greater than sourceAccount's + // seqLedger. + uint32 minSeqLedgerGap; + + // For the transaction to be valid, there must be a signature + // corresponding to every Signer in this array, even if the + // signature is not otherwise required by the sourceAccount or + // operations. + SignerKey extraSigners<2>; +}; + +enum PreconditionType +{ + PRECOND_NONE = 0, + PRECOND_TIME = 1, + PRECOND_V2 = 2 +}; + +union Preconditions switch (PreconditionType type) +{ +case PRECOND_NONE: + void; +case PRECOND_TIME: + TimeBounds timeBounds; +case PRECOND_V2: + PreconditionsV2 v2; +}; + +// maximum number of operations per transaction +const MAX_OPS_PER_TX = 100; + +// TransactionV0 is a transaction with the AccountID discriminant stripped off, +// leaving a raw ed25519 public key to identify the source account. This is used +// for backwards compatibility starting from the protocol 12/13 boundary. If an +// "old-style" TransactionEnvelope containing a Transaction is parsed with this +// XDR definition, it will be parsed as a "new-style" TransactionEnvelope +// containing a TransactionV0. +struct TransactionV0 +{ + uint256 sourceAccountEd25519; + uint32 fee; + SequenceNumber seqNum; + TimeBounds* timeBounds; + Memo memo; + Operation operations; + int v; +}; + +struct TransactionV0Envelope +{ + TransactionV0 tx; + /* Each decorated signature is a signature over the SHA256 hash of + * a TransactionSignaturePayload */ + DecoratedSignature signatures<20>; +}; + +/* a transaction is a container for a set of operations + - is executed by an account + - fees are collected from the account + - operations are executed in order as one ACID transaction + either all operations are applied or none are + if any returns a failing code +*/ +struct Transaction +{ + // account used to run the transaction + MuxedAccount sourceAccount; + + // the fee the sourceAccount will pay + uint32 fee; + + // sequence number to consume in the account + SequenceNumber seqNum; + + // validity conditions + Preconditions cond; + + Memo memo; + + Operation operations; + + // reserved for future use + int v; + void; +}; + +struct TransactionV1Envelope +{ + Transaction tx; + /* Each decorated signature is a signature over the SHA256 hash of + * a TransactionSignaturePayload */ + DecoratedSignature signatures<20>; +}; + +union FeeBumpTransaction_innerTx switch (EnvelopeType type) +{ +case ENVELOPE_TYPE_TX: + TransactionV1Envelope v1; +}; + +struct FeeBumpTransaction +{ + MuxedAccount feeSource; + int64 fee; + FeeBumpTransaction_innerTx innerTx; + int v; +}; + +struct FeeBumpTransactionEnvelope +{ + FeeBumpTransaction tx; + /* Each decorated signature is a signature over the SHA256 hash of + * a TransactionSignaturePayload */ + DecoratedSignature signatures<20>; +}; + +/* A TransactionEnvelope wraps a transaction with signatures. */ +union TransactionEnvelope switch (EnvelopeType type) +{ +case ENVELOPE_TYPE_TX_V0: + TransactionV0Envelope v0; +case ENVELOPE_TYPE_TX: + TransactionV1Envelope v1; +case ENVELOPE_TYPE_TX_FEE_BUMP: + FeeBumpTransactionEnvelope feeBump; +}; + +union TransactionSignaturePayload_taggedTransaction switch (EnvelopeType type) +{ + // Backwards Compatibility: Use ENVELOPE_TYPE_TX to sign ENVELOPE_TYPE_TX_V0 + case ENVELOPE_TYPE_TX: + Transaction tx; + case ENVELOPE_TYPE_TX_FEE_BUMP: + FeeBumpTransaction feeBump; +}; + +struct TransactionSignaturePayload +{ + Hash networkId; + TransactionSignaturePayload_taggedTransaction taggedTransaction; +}; + +/* Operation Results section */ + +enum ClaimAtomType +{ + CLAIM_ATOM_TYPE_V0 = 0, + CLAIM_ATOM_TYPE_ORDER_BOOK = 1, + CLAIM_ATOM_TYPE_LIQUIDITY_POOL = 2 +}; + +// ClaimOfferAtomV0 is a ClaimOfferAtom with the AccountID discriminant stripped +// off, leaving a raw ed25519 public key to identify the source account. This is +// used for backwards compatibility starting from the protocol 17/18 boundary. +// If an "old-style" ClaimOfferAtom is parsed with this XDR definition, it will +// be parsed as a "new-style" ClaimAtom containing a ClaimOfferAtomV0. +struct ClaimOfferAtomV0 +{ + // emitted to identify the offer + uint256 sellerEd25519; // Account that owns the offer + int64 offerID; + + // amount and asset taken from the owner + Asset assetSold; + int64 amountSold; + + // amount and asset sent to the owner + Asset assetBought; + int64 amountBought; +}; + +struct ClaimOfferAtom +{ + // emitted to identify the offer + AccountID sellerID; // Account that owns the offer + int64 offerID; + + // amount and asset taken from the owner + Asset assetSold; + int64 amountSold; + + // amount and asset sent to the owner + Asset assetBought; + int64 amountBought; +}; + +struct ClaimLiquidityAtom +{ + PoolID liquidityPoolID; + + // amount and asset taken from the pool + Asset assetSold; + int64 amountSold; + + // amount and asset sent to the pool + Asset assetBought; + int64 amountBought; +}; + +/* This result is used when offers are taken or liquidity is exchanged with a + liquidity pool during an operation +*/ +union ClaimAtom switch (ClaimAtomType type) +{ +case CLAIM_ATOM_TYPE_V0: + ClaimOfferAtomV0 v0; +case CLAIM_ATOM_TYPE_ORDER_BOOK: + ClaimOfferAtom orderBook; +case CLAIM_ATOM_TYPE_LIQUIDITY_POOL: + ClaimLiquidityAtom liquidityPool; +}; + +/******* CreateAccount Result ********/ + +enum CreateAccountResultCode +{ + // codes considered as "success" for the operation + CREATE_ACCOUNT_SUCCESS = 0, // account was created + + // codes considered as "failure" for the operation + CREATE_ACCOUNT_MALFORMED = -1, // invalid destination + CREATE_ACCOUNT_UNDERFUNDED = -2, // not enough funds in source account + CREATE_ACCOUNT_LOW_RESERVE = + -3, // would create an account below the min reserve + CREATE_ACCOUNT_ALREADY_EXIST = -4 // account already exists +}; + +union CreateAccountResult switch (CreateAccountResultCode code) +{ +case CREATE_ACCOUNT_SUCCESS: + void; +case CREATE_ACCOUNT_MALFORMED: +case CREATE_ACCOUNT_UNDERFUNDED: +case CREATE_ACCOUNT_LOW_RESERVE: +case CREATE_ACCOUNT_ALREADY_EXIST: + void; +}; + +/******* Payment Result ********/ + +enum PaymentResultCode +{ + // codes considered as "success" for the operation + PAYMENT_SUCCESS = 0, // payment successfully completed + + // codes considered as "failure" for the operation + PAYMENT_MALFORMED = -1, // bad input + PAYMENT_UNDERFUNDED = -2, // not enough funds in source account + PAYMENT_SRC_NO_TRUST = -3, // no trust line on source account + PAYMENT_SRC_NOT_AUTHORIZED = -4, // source not authorized to transfer + PAYMENT_NO_DESTINATION = -5, // destination account does not exist + PAYMENT_NO_TRUST = -6, // destination missing a trust line for asset + PAYMENT_NOT_AUTHORIZED = -7, // destination not authorized to hold asset + PAYMENT_LINE_FULL = -8, // destination would go above their limit + PAYMENT_NO_ISSUER = -9 // missing issuer on asset +}; + +union PaymentResult switch (PaymentResultCode code) +{ +case PAYMENT_SUCCESS: + void; +case PAYMENT_MALFORMED: +case PAYMENT_UNDERFUNDED: +case PAYMENT_SRC_NO_TRUST: +case PAYMENT_SRC_NOT_AUTHORIZED: +case PAYMENT_NO_DESTINATION: +case PAYMENT_NO_TRUST: +case PAYMENT_NOT_AUTHORIZED: +case PAYMENT_LINE_FULL: +case PAYMENT_NO_ISSUER: + void; +}; + +/******* PathPaymentStrictReceive Result ********/ + +enum PathPaymentStrictReceiveResultCode +{ + // codes considered as "success" for the operation + PATH_PAYMENT_STRICT_RECEIVE_SUCCESS = 0, // success + + // codes considered as "failure" for the operation + PATH_PAYMENT_STRICT_RECEIVE_MALFORMED = -1, // bad input + PATH_PAYMENT_STRICT_RECEIVE_UNDERFUNDED = + -2, // not enough funds in source account + PATH_PAYMENT_STRICT_RECEIVE_SRC_NO_TRUST = + -3, // no trust line on source account + PATH_PAYMENT_STRICT_RECEIVE_SRC_NOT_AUTHORIZED = + -4, // source not authorized to transfer + PATH_PAYMENT_STRICT_RECEIVE_NO_DESTINATION = + -5, // destination account does not exist + PATH_PAYMENT_STRICT_RECEIVE_NO_TRUST = + -6, // dest missing a trust line for asset + PATH_PAYMENT_STRICT_RECEIVE_NOT_AUTHORIZED = + -7, // dest not authorized to hold asset + PATH_PAYMENT_STRICT_RECEIVE_LINE_FULL = + -8, // dest would go above their limit + PATH_PAYMENT_STRICT_RECEIVE_NO_ISSUER = -9, // missing issuer on one asset + PATH_PAYMENT_STRICT_RECEIVE_TOO_FEW_OFFERS = + -10, // not enough offers to satisfy path + PATH_PAYMENT_STRICT_RECEIVE_OFFER_CROSS_SELF = + -11, // would cross one of its own offers + PATH_PAYMENT_STRICT_RECEIVE_OVER_SENDMAX = -12 // could not satisfy sendmax +}; + +struct SimplePaymentResult +{ + AccountID destination; + Asset asset; + int64 amount; +}; + +union PathPaymentStrictReceiveResult switch ( + PathPaymentStrictReceiveResultCode code) +{ +case PATH_PAYMENT_STRICT_RECEIVE_SUCCESS: + struct + { + ClaimAtom offers<>; + SimplePaymentResult last; + } success; +case PATH_PAYMENT_STRICT_RECEIVE_MALFORMED: +case PATH_PAYMENT_STRICT_RECEIVE_UNDERFUNDED: +case PATH_PAYMENT_STRICT_RECEIVE_SRC_NO_TRUST: +case PATH_PAYMENT_STRICT_RECEIVE_SRC_NOT_AUTHORIZED: +case PATH_PAYMENT_STRICT_RECEIVE_NO_DESTINATION: +case PATH_PAYMENT_STRICT_RECEIVE_NO_TRUST: +case PATH_PAYMENT_STRICT_RECEIVE_NOT_AUTHORIZED: +case PATH_PAYMENT_STRICT_RECEIVE_LINE_FULL: + void; +case PATH_PAYMENT_STRICT_RECEIVE_NO_ISSUER: + Asset noIssuer; // the asset that caused the error +case PATH_PAYMENT_STRICT_RECEIVE_TOO_FEW_OFFERS: +case PATH_PAYMENT_STRICT_RECEIVE_OFFER_CROSS_SELF: +case PATH_PAYMENT_STRICT_RECEIVE_OVER_SENDMAX: + void; +}; + +/******* PathPaymentStrictSend Result ********/ + +enum PathPaymentStrictSendResultCode +{ + // codes considered as "success" for the operation + PATH_PAYMENT_STRICT_SEND_SUCCESS = 0, // success + + // codes considered as "failure" for the operation + PATH_PAYMENT_STRICT_SEND_MALFORMED = -1, // bad input + PATH_PAYMENT_STRICT_SEND_UNDERFUNDED = + -2, // not enough funds in source account + PATH_PAYMENT_STRICT_SEND_SRC_NO_TRUST = + -3, // no trust line on source account + PATH_PAYMENT_STRICT_SEND_SRC_NOT_AUTHORIZED = + -4, // source not authorized to transfer + PATH_PAYMENT_STRICT_SEND_NO_DESTINATION = + -5, // destination account does not exist + PATH_PAYMENT_STRICT_SEND_NO_TRUST = + -6, // dest missing a trust line for asset + PATH_PAYMENT_STRICT_SEND_NOT_AUTHORIZED = + -7, // dest not authorized to hold asset + PATH_PAYMENT_STRICT_SEND_LINE_FULL = -8, // dest would go above their limit + PATH_PAYMENT_STRICT_SEND_NO_ISSUER = -9, // missing issuer on one asset + PATH_PAYMENT_STRICT_SEND_TOO_FEW_OFFERS = + -10, // not enough offers to satisfy path + PATH_PAYMENT_STRICT_SEND_OFFER_CROSS_SELF = + -11, // would cross one of its own offers + PATH_PAYMENT_STRICT_SEND_UNDER_DESTMIN = -12 // could not satisfy destMin +}; + +union PathPaymentStrictSendResult switch (PathPaymentStrictSendResultCode code) +{ +case PATH_PAYMENT_STRICT_SEND_SUCCESS: + struct + { + ClaimAtom offers<>; + SimplePaymentResult last; + } success; +case PATH_PAYMENT_STRICT_SEND_MALFORMED: +case PATH_PAYMENT_STRICT_SEND_UNDERFUNDED: +case PATH_PAYMENT_STRICT_SEND_SRC_NO_TRUST: +case PATH_PAYMENT_STRICT_SEND_SRC_NOT_AUTHORIZED: +case PATH_PAYMENT_STRICT_SEND_NO_DESTINATION: +case PATH_PAYMENT_STRICT_SEND_NO_TRUST: +case PATH_PAYMENT_STRICT_SEND_NOT_AUTHORIZED: +case PATH_PAYMENT_STRICT_SEND_LINE_FULL: + void; +case PATH_PAYMENT_STRICT_SEND_NO_ISSUER: + Asset noIssuer; // the asset that caused the error +case PATH_PAYMENT_STRICT_SEND_TOO_FEW_OFFERS: +case PATH_PAYMENT_STRICT_SEND_OFFER_CROSS_SELF: +case PATH_PAYMENT_STRICT_SEND_UNDER_DESTMIN: + void; +}; + +/******* ManageSellOffer Result ********/ + +enum ManageSellOfferResultCode +{ + // codes considered as "success" for the operation + MANAGE_SELL_OFFER_SUCCESS = 0, + + // codes considered as "failure" for the operation + MANAGE_SELL_OFFER_MALFORMED = -1, // generated offer would be invalid + MANAGE_SELL_OFFER_SELL_NO_TRUST = + -2, // no trust line for what we're selling + MANAGE_SELL_OFFER_BUY_NO_TRUST = -3, // no trust line for what we're buying + MANAGE_SELL_OFFER_SELL_NOT_AUTHORIZED = -4, // not authorized to sell + MANAGE_SELL_OFFER_BUY_NOT_AUTHORIZED = -5, // not authorized to buy + MANAGE_SELL_OFFER_LINE_FULL = -6, // can't receive more of what it's buying + MANAGE_SELL_OFFER_UNDERFUNDED = -7, // doesn't hold what it's trying to sell + MANAGE_SELL_OFFER_CROSS_SELF = + -8, // would cross an offer from the same user + MANAGE_SELL_OFFER_SELL_NO_ISSUER = -9, // no issuer for what we're selling + MANAGE_SELL_OFFER_BUY_NO_ISSUER = -10, // no issuer for what we're buying + + // update errors + MANAGE_SELL_OFFER_NOT_FOUND = + -11, // offerID does not match an existing offer + + MANAGE_SELL_OFFER_LOW_RESERVE = + -12 // not enough funds to create a new Offer +}; + +enum ManageOfferEffect +{ + MANAGE_OFFER_CREATED = 0, + MANAGE_OFFER_UPDATED = 1, + MANAGE_OFFER_DELETED = 2 +}; + +union ManageOfferSuccesResult_offer switch (ManageOfferEffect effect) +{ +case MANAGE_OFFER_CREATED: +case MANAGE_OFFER_UPDATED: + OfferEntry offer; +case MANAGE_OFFER_DELETED: + void; +}; + +struct ManageOfferSuccessResult +{ + // offers that got claimed while creating this offer + ClaimAtom offersClaimed<>; + + ManageOfferSuccesResult_offer offer; +}; + +union ManageSellOfferResult switch (ManageSellOfferResultCode code) +{ +case MANAGE_SELL_OFFER_SUCCESS: + ManageOfferSuccessResult success; +case MANAGE_SELL_OFFER_MALFORMED: +case MANAGE_SELL_OFFER_SELL_NO_TRUST: +case MANAGE_SELL_OFFER_BUY_NO_TRUST: +case MANAGE_SELL_OFFER_SELL_NOT_AUTHORIZED: +case MANAGE_SELL_OFFER_BUY_NOT_AUTHORIZED: +case MANAGE_SELL_OFFER_LINE_FULL: +case MANAGE_SELL_OFFER_UNDERFUNDED: +case MANAGE_SELL_OFFER_CROSS_SELF: +case MANAGE_SELL_OFFER_SELL_NO_ISSUER: +case MANAGE_SELL_OFFER_BUY_NO_ISSUER: +case MANAGE_SELL_OFFER_NOT_FOUND: +case MANAGE_SELL_OFFER_LOW_RESERVE: + void; +}; + +/******* ManageBuyOffer Result ********/ + +enum ManageBuyOfferResultCode +{ + // codes considered as "success" for the operation + MANAGE_BUY_OFFER_SUCCESS = 0, + + // codes considered as "failure" for the operation + MANAGE_BUY_OFFER_MALFORMED = -1, // generated offer would be invalid + MANAGE_BUY_OFFER_SELL_NO_TRUST = -2, // no trust line for what we're selling + MANAGE_BUY_OFFER_BUY_NO_TRUST = -3, // no trust line for what we're buying + MANAGE_BUY_OFFER_SELL_NOT_AUTHORIZED = -4, // not authorized to sell + MANAGE_BUY_OFFER_BUY_NOT_AUTHORIZED = -5, // not authorized to buy + MANAGE_BUY_OFFER_LINE_FULL = -6, // can't receive more of what it's buying + MANAGE_BUY_OFFER_UNDERFUNDED = -7, // doesn't hold what it's trying to sell + MANAGE_BUY_OFFER_CROSS_SELF = -8, // would cross an offer from the same user + MANAGE_BUY_OFFER_SELL_NO_ISSUER = -9, // no issuer for what we're selling + MANAGE_BUY_OFFER_BUY_NO_ISSUER = -10, // no issuer for what we're buying + + // update errors + MANAGE_BUY_OFFER_NOT_FOUND = + -11, // offerID does not match an existing offer + + MANAGE_BUY_OFFER_LOW_RESERVE = -12 // not enough funds to create a new Offer +}; + +union ManageBuyOfferResult switch (ManageBuyOfferResultCode code) +{ +case MANAGE_BUY_OFFER_SUCCESS: + ManageOfferSuccessResult success; +case MANAGE_BUY_OFFER_MALFORMED: +case MANAGE_BUY_OFFER_SELL_NO_TRUST: +case MANAGE_BUY_OFFER_BUY_NO_TRUST: +case MANAGE_BUY_OFFER_SELL_NOT_AUTHORIZED: +case MANAGE_BUY_OFFER_BUY_NOT_AUTHORIZED: +case MANAGE_BUY_OFFER_LINE_FULL: +case MANAGE_BUY_OFFER_UNDERFUNDED: +case MANAGE_BUY_OFFER_CROSS_SELF: +case MANAGE_BUY_OFFER_SELL_NO_ISSUER: +case MANAGE_BUY_OFFER_BUY_NO_ISSUER: +case MANAGE_BUY_OFFER_NOT_FOUND: +case MANAGE_BUY_OFFER_LOW_RESERVE: + void; +}; + +/******* SetOptions Result ********/ + +enum SetOptionsResultCode +{ + // codes considered as "success" for the operation + SET_OPTIONS_SUCCESS = 0, + // codes considered as "failure" for the operation + SET_OPTIONS_LOW_RESERVE = -1, // not enough funds to add a signer + SET_OPTIONS_TOO_MANY_SIGNERS = -2, // max number of signers already reached + SET_OPTIONS_BAD_FLAGS = -3, // invalid combination of clear/set flags + SET_OPTIONS_INVALID_INFLATION = -4, // inflation account does not exist + SET_OPTIONS_CANT_CHANGE = -5, // can no longer change this option + SET_OPTIONS_UNKNOWN_FLAG = -6, // can't set an unknown flag + SET_OPTIONS_THRESHOLD_OUT_OF_RANGE = -7, // bad value for weight/threshold + SET_OPTIONS_BAD_SIGNER = -8, // signer cannot be masterkey + SET_OPTIONS_INVALID_HOME_DOMAIN = -9 // malformed home domain +}; + +union SetOptionsResult switch (SetOptionsResultCode code) +{ +case SET_OPTIONS_SUCCESS: + void; +default: + void; +}; + +/******* ChangeTrust Result ********/ + +enum ChangeTrustResultCode +{ + // codes considered as "success" for the operation + CHANGE_TRUST_SUCCESS = 0, + // codes considered as "failure" for the operation + CHANGE_TRUST_MALFORMED = -1, // bad input + CHANGE_TRUST_NO_ISSUER = -2, // could not find issuer + CHANGE_TRUST_INVALID_LIMIT = -3, // cannot drop limit below balance + // cannot create with a limit of 0 + CHANGE_TRUST_LOW_RESERVE = -4, // not enough funds to create a new trust line, + CHANGE_TRUST_SELF_NOT_ALLOWED = -5 // trusting self is not allowed +}; + +union ChangeTrustResult switch (ChangeTrustResultCode code) +{ +case CHANGE_TRUST_SUCCESS: + void; +default: + void; +}; + +/******* AllowTrust Result ********/ + +enum AllowTrustResultCode +{ + // codes considered as "success" for the operation + ALLOW_TRUST_SUCCESS = 0, + // codes considered as "failure" for the operation + ALLOW_TRUST_MALFORMED = -1, // asset is not ASSET_TYPE_ALPHANUM + ALLOW_TRUST_NO_TRUST_LINE = -2, // trustor does not have a trustline + // source account does not require trust + ALLOW_TRUST_TRUST_NOT_REQUIRED = -3, + ALLOW_TRUST_CANT_REVOKE = -4, // source account can't revoke trust, + ALLOW_TRUST_SELF_NOT_ALLOWED = -5 // trusting self is not allowed +}; + +union AllowTrustResult switch (AllowTrustResultCode code) +{ +case ALLOW_TRUST_SUCCESS: + void; +default: + void; +}; + +/******* AccountMerge Result ********/ + +enum AccountMergeResultCode +{ + // codes considered as "success" for the operation + ACCOUNT_MERGE_SUCCESS = 0, + // codes considered as "failure" for the operation + ACCOUNT_MERGE_MALFORMED = -1, // can't merge onto itself + ACCOUNT_MERGE_NO_ACCOUNT = -2, // destination does not exist + ACCOUNT_MERGE_IMMUTABLE_SET = -3, // source account has AUTH_IMMUTABLE set + ACCOUNT_MERGE_HAS_SUB_ENTRIES = -4 // account has trust lines/offers +}; + +union AccountMergeResult switch (AccountMergeResultCode code) +{ +case ACCOUNT_MERGE_SUCCESS: + int64 sourceAccountBalance; // how much got transfered from source account +default: + void; +}; + +/******* Inflation Result ********/ + +enum InflationResultCode +{ + // codes considered as "success" for the operation + INFLATION_SUCCESS = 0, + // codes considered as "failure" for the operation + INFLATION_NOT_TIME = -1 +}; + +struct InflationPayout // or use PaymentResultAtom to limit types? +{ + AccountID destination; + int64 amount; +}; + +union InflationResult switch (InflationResultCode code) +{ +case INFLATION_SUCCESS: + InflationPayout payouts<>; +default: + void; +}; + +/******* ManageData Result ********/ + +enum ManageDataResultCode +{ + // codes considered as "success" for the operation + MANAGE_DATA_SUCCESS = 0, + // codes considered as "failure" for the operation + MANAGE_DATA_NOT_SUPPORTED_YET = + -1, // The network hasn't moved to this protocol change yet + MANAGE_DATA_NAME_NOT_FOUND = + -2, // Trying to remove a Data Entry that isn't there + MANAGE_DATA_LOW_RESERVE = -3, // not enough funds to create a new Data Entry + MANAGE_DATA_INVALID_NAME = -4 // Name not a valid string +}; + +union ManageDataResult switch (ManageDataResultCode code) +{ +case MANAGE_DATA_SUCCESS: + void; +case MANAGE_DATA_NOT_SUPPORTED_YET: +case MANAGE_DATA_NAME_NOT_FOUND: +case MANAGE_DATA_LOW_RESERVE: +case MANAGE_DATA_INVALID_NAME: + void; +}; + +/******* BumpSequence Result ********/ + +enum BumpSequenceResultCode +{ + // codes considered as "success" for the operation + BUMP_SEQUENCE_SUCCESS = 0, + // codes considered as "failure" for the operation + BUMP_SEQUENCE_BAD_SEQ = -1 // `bumpTo` is not within bounds +}; + +union BumpSequenceResult switch (BumpSequenceResultCode code) +{ +case BUMP_SEQUENCE_SUCCESS: + void; +case BUMP_SEQUENCE_BAD_SEQ: + void; +}; + +/******* CreateClaimableBalance Result ********/ + +enum CreateClaimableBalanceResultCode +{ + CREATE_CLAIMABLE_BALANCE_SUCCESS = 0, + CREATE_CLAIMABLE_BALANCE_MALFORMED = -1, + CREATE_CLAIMABLE_BALANCE_LOW_RESERVE = -2, + CREATE_CLAIMABLE_BALANCE_NO_TRUST = -3, + CREATE_CLAIMABLE_BALANCE_NOT_AUTHORIZED = -4, + CREATE_CLAIMABLE_BALANCE_UNDERFUNDED = -5 +}; + +union CreateClaimableBalanceResult switch ( + CreateClaimableBalanceResultCode code) +{ +case CREATE_CLAIMABLE_BALANCE_SUCCESS: + ClaimableBalanceID balanceID; +case CREATE_CLAIMABLE_BALANCE_MALFORMED: +case CREATE_CLAIMABLE_BALANCE_LOW_RESERVE: +case CREATE_CLAIMABLE_BALANCE_NO_TRUST: +case CREATE_CLAIMABLE_BALANCE_NOT_AUTHORIZED: +case CREATE_CLAIMABLE_BALANCE_UNDERFUNDED: + void; +}; + +/******* ClaimClaimableBalance Result ********/ + +enum ClaimClaimableBalanceResultCode +{ + CLAIM_CLAIMABLE_BALANCE_SUCCESS = 0, + CLAIM_CLAIMABLE_BALANCE_DOES_NOT_EXIST = -1, + CLAIM_CLAIMABLE_BALANCE_CANNOT_CLAIM = -2, + CLAIM_CLAIMABLE_BALANCE_LINE_FULL = -3, + CLAIM_CLAIMABLE_BALANCE_NO_TRUST = -4, + CLAIM_CLAIMABLE_BALANCE_NOT_AUTHORIZED = -5 +}; + +union ClaimClaimableBalanceResult switch (ClaimClaimableBalanceResultCode code) +{ +case CLAIM_CLAIMABLE_BALANCE_SUCCESS: + void; +case CLAIM_CLAIMABLE_BALANCE_DOES_NOT_EXIST: +case CLAIM_CLAIMABLE_BALANCE_CANNOT_CLAIM: +case CLAIM_CLAIMABLE_BALANCE_LINE_FULL: +case CLAIM_CLAIMABLE_BALANCE_NO_TRUST: +case CLAIM_CLAIMABLE_BALANCE_NOT_AUTHORIZED: + void; +}; + +/******* BeginSponsoringFutureReserves Result ********/ + +enum BeginSponsoringFutureReservesResultCode +{ + // codes considered as "success" for the operation + BEGIN_SPONSORING_FUTURE_RESERVES_SUCCESS = 0, + + // codes considered as "failure" for the operation + BEGIN_SPONSORING_FUTURE_RESERVES_MALFORMED = -1, + BEGIN_SPONSORING_FUTURE_RESERVES_ALREADY_SPONSORED = -2, + BEGIN_SPONSORING_FUTURE_RESERVES_RECURSIVE = -3 +}; + +union BeginSponsoringFutureReservesResult switch ( + BeginSponsoringFutureReservesResultCode code) +{ +case BEGIN_SPONSORING_FUTURE_RESERVES_SUCCESS: + void; +case BEGIN_SPONSORING_FUTURE_RESERVES_MALFORMED: +case BEGIN_SPONSORING_FUTURE_RESERVES_ALREADY_SPONSORED: +case BEGIN_SPONSORING_FUTURE_RESERVES_RECURSIVE: + void; +}; + +/******* EndSponsoringFutureReserves Result ********/ + +enum EndSponsoringFutureReservesResultCode +{ + // codes considered as "success" for the operation + END_SPONSORING_FUTURE_RESERVES_SUCCESS = 0, + + // codes considered as "failure" for the operation + END_SPONSORING_FUTURE_RESERVES_NOT_SPONSORED = -1 +}; + +union EndSponsoringFutureReservesResult switch ( + EndSponsoringFutureReservesResultCode code) +{ +case END_SPONSORING_FUTURE_RESERVES_SUCCESS: + void; +case END_SPONSORING_FUTURE_RESERVES_NOT_SPONSORED: + void; +}; + +/******* RevokeSponsorship Result ********/ + +enum RevokeSponsorshipResultCode +{ + // codes considered as "success" for the operation + REVOKE_SPONSORSHIP_SUCCESS = 0, + + // codes considered as "failure" for the operation + REVOKE_SPONSORSHIP_DOES_NOT_EXIST = -1, + REVOKE_SPONSORSHIP_NOT_SPONSOR = -2, + REVOKE_SPONSORSHIP_LOW_RESERVE = -3, + REVOKE_SPONSORSHIP_ONLY_TRANSFERABLE = -4, + REVOKE_SPONSORSHIP_MALFORMED = -5 +}; + +union RevokeSponsorshipResult switch (RevokeSponsorshipResultCode code) +{ +case REVOKE_SPONSORSHIP_SUCCESS: + void; +case REVOKE_SPONSORSHIP_DOES_NOT_EXIST: +case REVOKE_SPONSORSHIP_NOT_SPONSOR: +case REVOKE_SPONSORSHIP_LOW_RESERVE: +case REVOKE_SPONSORSHIP_ONLY_TRANSFERABLE: +case REVOKE_SPONSORSHIP_MALFORMED: + void; +}; + +/******* Clawback Result ********/ + +enum ClawbackResultCode +{ + // codes considered as "success" for the operation + CLAWBACK_SUCCESS = 0, + + // codes considered as "failure" for the operation + CLAWBACK_MALFORMED = -1, + CLAWBACK_NOT_CLAWBACK_ENABLED = -2, + CLAWBACK_NO_TRUST = -3, + CLAWBACK_UNDERFUNDED = -4 +}; + +union ClawbackResult switch (ClawbackResultCode code) +{ +case CLAWBACK_SUCCESS: + void; +case CLAWBACK_MALFORMED: +case CLAWBACK_NOT_CLAWBACK_ENABLED: +case CLAWBACK_NO_TRUST: +case CLAWBACK_UNDERFUNDED: + void; +}; + +/******* ClawbackClaimableBalance Result ********/ + +enum ClawbackClaimableBalanceResultCode +{ + // codes considered as "success" for the operation + CLAWBACK_CLAIMABLE_BALANCE_SUCCESS = 0, + + // codes considered as "failure" for the operation + CLAWBACK_CLAIMABLE_BALANCE_DOES_NOT_EXIST = -1, + CLAWBACK_CLAIMABLE_BALANCE_NOT_ISSUER = -2, + CLAWBACK_CLAIMABLE_BALANCE_NOT_CLAWBACK_ENABLED = -3 +}; + +union ClawbackClaimableBalanceResult switch ( + ClawbackClaimableBalanceResultCode code) +{ +case CLAWBACK_CLAIMABLE_BALANCE_SUCCESS: + void; +case CLAWBACK_CLAIMABLE_BALANCE_DOES_NOT_EXIST: +case CLAWBACK_CLAIMABLE_BALANCE_NOT_ISSUER: +case CLAWBACK_CLAIMABLE_BALANCE_NOT_CLAWBACK_ENABLED: + void; +}; + +/******* SetTrustLineFlags Result ********/ + +enum SetTrustLineFlagsResultCode +{ + // codes considered as "success" for the operation + SET_TRUST_LINE_FLAGS_SUCCESS = 0, + + // codes considered as "failure" for the operation + SET_TRUST_LINE_FLAGS_MALFORMED = -1, + SET_TRUST_LINE_FLAGS_NO_TRUST_LINE = -2, + SET_TRUST_LINE_FLAGS_CANT_REVOKE = -3, + SET_TRUST_LINE_FLAGS_INVALID_STATE = -4, + SET_TRUST_LINE_FLAGS_LOW_RESERVE = -5 // claimable balances can't be created + // on revoke due to low reserves +}; + +union SetTrustLineFlagsResult switch (SetTrustLineFlagsResultCode code) +{ +case SET_TRUST_LINE_FLAGS_SUCCESS: + void; +case SET_TRUST_LINE_FLAGS_MALFORMED: +case SET_TRUST_LINE_FLAGS_NO_TRUST_LINE: +case SET_TRUST_LINE_FLAGS_CANT_REVOKE: +case SET_TRUST_LINE_FLAGS_INVALID_STATE: +case SET_TRUST_LINE_FLAGS_LOW_RESERVE: + void; +}; + +/******* LiquidityPoolDeposit Result ********/ + +enum LiquidityPoolDepositResultCode +{ + // codes considered as "success" for the operation + LIQUIDITY_POOL_DEPOSIT_SUCCESS = 0, + + // codes considered as "failure" for the operation + LIQUIDITY_POOL_DEPOSIT_MALFORMED = -1, // bad input + LIQUIDITY_POOL_DEPOSIT_NO_TRUST = -2, // no trust line for one of the + // assets + LIQUIDITY_POOL_DEPOSIT_NOT_AUTHORIZED = -3, // not authorized for one of the + // assets + LIQUIDITY_POOL_DEPOSIT_UNDERFUNDED = -4, // not enough balance for one of + // the assets + LIQUIDITY_POOL_DEPOSIT_LINE_FULL = -5, // pool share trust line doesn't + // have sufficient limit + LIQUIDITY_POOL_DEPOSIT_BAD_PRICE = -6, // deposit price outside bounds + LIQUIDITY_POOL_DEPOSIT_POOL_FULL = -7 // pool reserves are full +}; + +union LiquidityPoolDepositResult switch (LiquidityPoolDepositResultCode code) +{ +case LIQUIDITY_POOL_DEPOSIT_SUCCESS: + void; +case LIQUIDITY_POOL_DEPOSIT_MALFORMED: +case LIQUIDITY_POOL_DEPOSIT_NO_TRUST: +case LIQUIDITY_POOL_DEPOSIT_NOT_AUTHORIZED: +case LIQUIDITY_POOL_DEPOSIT_UNDERFUNDED: +case LIQUIDITY_POOL_DEPOSIT_LINE_FULL: +case LIQUIDITY_POOL_DEPOSIT_BAD_PRICE: +case LIQUIDITY_POOL_DEPOSIT_POOL_FULL: + void; +}; + +/******* LiquidityPoolWithdraw Result ********/ + +enum LiquidityPoolWithdrawResultCode +{ + // codes considered as "success" for the operation + LIQUIDITY_POOL_WITHDRAW_SUCCESS = 0, + + // codes considered as "failure" for the operation + LIQUIDITY_POOL_WITHDRAW_MALFORMED = -1, // bad input + LIQUIDITY_POOL_WITHDRAW_NO_TRUST = -2, // no trust line for one of the + // assets + LIQUIDITY_POOL_WITHDRAW_UNDERFUNDED = -3, // not enough balance of the + // pool share + LIQUIDITY_POOL_WITHDRAW_LINE_FULL = -4, // would go above limit for one + // of the assets + LIQUIDITY_POOL_WITHDRAW_UNDER_MINIMUM = -5 // didn't withdraw enough +}; + +union LiquidityPoolWithdrawResult switch (LiquidityPoolWithdrawResultCode code) +{ +case LIQUIDITY_POOL_WITHDRAW_SUCCESS: + void; +case LIQUIDITY_POOL_WITHDRAW_MALFORMED: +case LIQUIDITY_POOL_WITHDRAW_NO_TRUST: +case LIQUIDITY_POOL_WITHDRAW_UNDERFUNDED: +case LIQUIDITY_POOL_WITHDRAW_LINE_FULL: +case LIQUIDITY_POOL_WITHDRAW_UNDER_MINIMUM: + void; +}; + +/* High level Operation Result */ +enum OperationResultCode +{ + OpINNER = 0, // inner object result is valid + + OpBAD_AUTH = -1, // too few valid signatures / wrong network + OpNO_ACCOUNT = -2, // source account was not found + OpNOT_SUPPORTED = -3, // operation not supported at this time + OpTOO_MANY_SUBENTRIES = -4, // max number of subentries already reached + OpEXCEEDED_WORK_LIMIT = -5, // operation did too much work + OpTOO_MANY_SPONSORING = -6 // account is sponsoring too many entries +}; + +union OperationResultTr switch (OperationType type) + { + case CREATE_ACCOUNT: + CreateAccountResult createAccountResult; + case PAYMENT: + PaymentResult paymentResult; + case PATH_PAYMENT_STRICT_RECEIVE: + PathPaymentStrictReceiveResult pathPaymentStrictReceiveResult; + case MANAGE_SELL_OFFER: + ManageSellOfferResult manageSellOfferResult; + case CREATE_PASSIVE_SELL_OFFER: + ManageSellOfferResult createPassiveSellOfferResult; + case SET_OPTIONS: + SetOptionsResult setOptionsResult; + case CHANGE_TRUST: + ChangeTrustResult changeTrustResult; + case ALLOW_TRUST: + AllowTrustResult allowTrustResult; + case ACCOUNT_MERGE: + AccountMergeResult accountMergeResult; + case INFLATION: + InflationResult inflationResult; + case MANAGE_DATA: + ManageDataResult manageDataResult; + case BUMP_SEQUENCE: + BumpSequenceResult bumpSeqResult; + case MANAGE_BUY_OFFER: + ManageBuyOfferResult manageBuyOfferResult; + case PATH_PAYMENT_STRICT_SEND: + PathPaymentStrictSendResult pathPaymentStrictSendResult; + case CREATE_CLAIMABLE_BALANCE: + CreateClaimableBalanceResult createClaimableBalanceResult; + case CLAIM_CLAIMABLE_BALANCE: + ClaimClaimableBalanceResult claimClaimableBalanceResult; + case BEGIN_SPONSORING_FUTURE_RESERVES: + BeginSponsoringFutureReservesResult beginSponsoringFutureReservesResult; + case END_SPONSORING_FUTURE_RESERVES: + EndSponsoringFutureReservesResult endSponsoringFutureReservesResult; + case REVOKE_SPONSORSHIP: + RevokeSponsorshipResult revokeSponsorshipResult; + case CLAWBACK: + ClawbackResult clawbackResult; + case CLAWBACK_CLAIMABLE_BALANCE: + ClawbackClaimableBalanceResult clawbackClaimableBalanceResult; + case SET_TRUST_LINE_FLAGS: + SetTrustLineFlagsResult setTrustLineFlagsResult; + case LIQUIDITY_POOL_DEPOSIT: + LiquidityPoolDepositResult liquidityPoolDepositResult; + case LIQUIDITY_POOL_WITHDRAW: + LiquidityPoolWithdrawResult liquidityPoolWithdrawResult; + }; + +union OperationResult switch (OperationResultCode code) +{ +case OpINNER: + OperationResultTr tr; +case OpBAD_AUTH: +case OpNO_ACCOUNT: +case OpNOT_SUPPORTED: +case OpTOO_MANY_SUBENTRIES: +case OpEXCEEDED_WORK_LIMIT: +case OpTOO_MANY_SPONSORING: + void; +}; + +enum TransactionResultCode +{ + TRANSACTION_RESULT_SUCCESS = 0, // all operations succeeded + + TRANSACTION_RESULT_FAILED = -1, // one of the operations failed (none were applied) + + TRANSACTION_RESULT_TOO_EARLY = -2, // ledger closeTime before minTime + TRANSACTION_RESULT_TOO_LATE = -3, // ledger closeTime after maxTime + TRANSACTION_RESULT_MISSING_OPERATION = -4, // no operation was specified + TRANSACTION_RESULT_BAD_SEQ = -5, // sequence number does not match source account + + TRANSACTION_RESULT_BAD_AUTH = -6, // too few valid signatures / wrong network + TRANSACTION_RESULT_INSUFFICIENT_BALANCE = -7, // fee would bring account below reserve + TRANSACTION_RESULT_NO_ACCOUNT = -8, // source account not found + TRANSACTION_RESULT_INSUFFICIENT_FEE = -9, // fee is too small + TRANSACTION_RESULT_BAD_AUTH_EXTRA = -10, // unused signatures attached to transaction + TRANSACTION_RESULT_INTERNAL_ERROR = -11 // an unknown error occured +}; + +union TransactionResultResult switch (TransactionResultCode code) +{ +case TRANSACTION_RESULT_SUCCESS: +case TRANSACTION_RESULT_FAILED: + OperationResult results<>; +default: + void; +}; +struct TransactionResult +{ + int64 feeCharged; // actual fee charged for the transaction + + TransactionResultResult result; + + // reserved for future use + void; +}; diff --git a/bundled/Network/Stellar/TransactionXdr.hs b/bundled/Network/Stellar/TransactionXdr.hs new file mode 100644 index 0000000..8da3f4a --- /dev/null +++ b/bundled/Network/Stellar/TransactionXdr.hs @@ -0,0 +1,4911 @@ +-- |Generated from Stellar-transaction.x by +{-# LANGUAGE DataKinds, TypeFamilies #-} +module Network.Stellar.TransactionXdr where +import qualified Prelude +import qualified Control.Applicative +import qualified Network.ONCRPC.XDR as XDR + +type Hash = XDR.FixedOpaque 32 + +type Uint256 = XDR.FixedOpaque 32 + +type Uint32 = XDR.UnsignedInt + +type Int32 = XDR.Int + +type Uint64 = XDR.UnsignedHyper + +type Int64 = XDR.Hyper + +data CryptoKeyType = KEY_TYPE_ED25519 + | KEY_TYPE_PRE_AUTH_TX + | KEY_TYPE_HASH_X + | KEY_TYPE_ED25519_SIGNED_PAYLOAD + | KEY_TYPE_MUXED_ED25519 + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR CryptoKeyType where + xdrType _ = "CryptoKeyType" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum CryptoKeyType where + xdrFromEnum KEY_TYPE_ED25519 = 0 + xdrFromEnum KEY_TYPE_PRE_AUTH_TX = 1 + xdrFromEnum KEY_TYPE_HASH_X = 2 + xdrFromEnum KEY_TYPE_ED25519_SIGNED_PAYLOAD = 3 + xdrFromEnum KEY_TYPE_MUXED_ED25519 = 256 + xdrToEnum 0 = Prelude.return KEY_TYPE_ED25519 + xdrToEnum 1 = Prelude.return KEY_TYPE_PRE_AUTH_TX + xdrToEnum 2 = Prelude.return KEY_TYPE_HASH_X + xdrToEnum 3 = Prelude.return KEY_TYPE_ED25519_SIGNED_PAYLOAD + xdrToEnum 256 = Prelude.return KEY_TYPE_MUXED_ED25519 + xdrToEnum _ = Prelude.fail "invalid CryptoKeyType" + +data PublicKeyType = PUBLIC_KEY_TYPE_ED25519 + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR PublicKeyType where + xdrType _ = "PublicKeyType" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum PublicKeyType where + xdrFromEnum PUBLIC_KEY_TYPE_ED25519 = 0 + xdrToEnum 0 = Prelude.return PUBLIC_KEY_TYPE_ED25519 + xdrToEnum _ = Prelude.fail "invalid PublicKeyType" + +data MuxedAccount = MuxedAccount'KEY_TYPE_ED25519{muxedAccount'ed25519 + :: !Uint256} + | MuxedAccount'KEY_TYPE_MUXED_ED25519{muxedAccount'med25519'id :: + !Uint64, + muxedAccount'med25519'ed25519 :: !Uint256} + deriving (Prelude.Eq, Prelude.Show) + +muxedAccount'type :: MuxedAccount -> CryptoKeyType +muxedAccount'type = XDR.xdrDiscriminant + +instance XDR.XDR MuxedAccount where + xdrType _ = "MuxedAccount" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion MuxedAccount where + type XDRDiscriminant MuxedAccount = CryptoKeyType + xdrSplitUnion _x@MuxedAccount'KEY_TYPE_ED25519{} + = (0, XDR.xdrPut (muxedAccount'ed25519 _x)) + xdrSplitUnion _x@MuxedAccount'KEY_TYPE_MUXED_ED25519{} + = (256, + XDR.xdrPut (muxedAccount'med25519'id _x) Control.Applicative.*> + XDR.xdrPut (muxedAccount'med25519'ed25519 _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure MuxedAccount'KEY_TYPE_ED25519 + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 256 + = Control.Applicative.pure MuxedAccount'KEY_TYPE_MUXED_ED25519 + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = Prelude.fail "invalid MuxedAccount discriminant" + +data SignerKeyType = SIGNER_KEY_TYPE_ED25519 + | SIGNER_KEY_TYPE_PRE_AUTH_TX + | SIGNER_KEY_TYPE_HASH_X + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR SignerKeyType where + xdrType _ = "SignerKeyType" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum SignerKeyType where + xdrFromEnum SIGNER_KEY_TYPE_ED25519 = 0 + xdrFromEnum SIGNER_KEY_TYPE_PRE_AUTH_TX = 1 + xdrFromEnum SIGNER_KEY_TYPE_HASH_X = 2 + xdrToEnum 0 = Prelude.return SIGNER_KEY_TYPE_ED25519 + xdrToEnum 1 = Prelude.return SIGNER_KEY_TYPE_PRE_AUTH_TX + xdrToEnum 2 = Prelude.return SIGNER_KEY_TYPE_HASH_X + xdrToEnum _ = Prelude.fail "invalid SignerKeyType" + +data PublicKey = PublicKey'PUBLIC_KEY_TYPE_ED25519{publicKey'ed25519 + :: !Uint256} + deriving (Prelude.Eq, Prelude.Show) + +publicKey'type :: PublicKey -> PublicKeyType +publicKey'type = XDR.xdrDiscriminant + +instance XDR.XDR PublicKey where + xdrType _ = "PublicKey" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion PublicKey where + type XDRDiscriminant PublicKey = PublicKeyType + xdrSplitUnion _x@PublicKey'PUBLIC_KEY_TYPE_ED25519{} + = (0, XDR.xdrPut (publicKey'ed25519 _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure PublicKey'PUBLIC_KEY_TYPE_ED25519 + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c = Prelude.fail "invalid PublicKey discriminant" + +data SignerKey = SignerKey'SIGNER_KEY_TYPE_ED25519{signerKey'ed25519 + :: !Uint256} + | SignerKey'SIGNER_KEY_TYPE_PRE_AUTH_TX{signerKey'preAuthTx :: + !Uint256} + | SignerKey'SIGNER_KEY_TYPE_HASH_X{signerKey'hashX :: !Uint256} + deriving (Prelude.Eq, Prelude.Show) + +signerKey'type :: SignerKey -> SignerKeyType +signerKey'type = XDR.xdrDiscriminant + +instance XDR.XDR SignerKey where + xdrType _ = "SignerKey" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion SignerKey where + type XDRDiscriminant SignerKey = SignerKeyType + xdrSplitUnion _x@SignerKey'SIGNER_KEY_TYPE_ED25519{} + = (0, XDR.xdrPut (signerKey'ed25519 _x)) + xdrSplitUnion _x@SignerKey'SIGNER_KEY_TYPE_PRE_AUTH_TX{} + = (1, XDR.xdrPut (signerKey'preAuthTx _x)) + xdrSplitUnion _x@SignerKey'SIGNER_KEY_TYPE_HASH_X{} + = (2, XDR.xdrPut (signerKey'hashX _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure SignerKey'SIGNER_KEY_TYPE_ED25519 + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 1 + = Control.Applicative.pure SignerKey'SIGNER_KEY_TYPE_PRE_AUTH_TX + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 2 + = Control.Applicative.pure SignerKey'SIGNER_KEY_TYPE_HASH_X + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c = Prelude.fail "invalid SignerKey discriminant" + +type Signature = XDR.Opaque 64 + +type SignatureHint = XDR.FixedOpaque 4 + +type NodeID = PublicKey + +data Curve25519Secret = Curve25519Secret{curve25519Secret'key :: + !(XDR.FixedOpaque 32)} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR Curve25519Secret where + xdrType _ = "Curve25519Secret" + xdrPut _x = XDR.xdrPut (curve25519Secret'key _x) + xdrGet + = Control.Applicative.pure Curve25519Secret Control.Applicative.<*> + XDR.xdrGet + +data Curve25519Public = Curve25519Public{curve25519Public'key :: + !(XDR.FixedOpaque 32)} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR Curve25519Public where + xdrType _ = "Curve25519Public" + xdrPut _x = XDR.xdrPut (curve25519Public'key _x) + xdrGet + = Control.Applicative.pure Curve25519Public Control.Applicative.<*> + XDR.xdrGet + +data HmacSha256Key = HmacSha256Key{hmacSha256Key'key :: + !(XDR.FixedOpaque 32)} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR HmacSha256Key where + xdrType _ = "HmacSha256Key" + xdrPut _x = XDR.xdrPut (hmacSha256Key'key _x) + xdrGet + = Control.Applicative.pure HmacSha256Key Control.Applicative.<*> + XDR.xdrGet + +data HmacSha256Mac = HmacSha256Mac{hmacSha256Mac'mac :: + !(XDR.FixedOpaque 32)} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR HmacSha256Mac where + xdrType _ = "HmacSha256Mac" + xdrPut _x = XDR.xdrPut (hmacSha256Mac'mac _x) + xdrGet + = Control.Applicative.pure HmacSha256Mac Control.Applicative.<*> + XDR.xdrGet + +type AccountID = PublicKey + +type Thresholds = XDR.FixedOpaque 4 + +type String32 = XDR.String 32 + +type String64 = XDR.String 64 + +type SequenceNumber = Int64 + +type TimePoint = Uint64 + +type Duration = Uint64 + +type DataValue = XDR.Opaque 64 + +type PoolID = Hash + +type AssetCode4 = XDR.FixedOpaque 4 + +type AssetCode12 = XDR.FixedOpaque 12 + +data AssetType = ASSET_TYPE_NATIVE + | ASSET_TYPE_CREDIT_ALPHANUM4 + | ASSET_TYPE_CREDIT_ALPHANUM12 + | ASSET_TYPE_POOL_SHARE + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR AssetType where + xdrType _ = "AssetType" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum AssetType where + xdrFromEnum ASSET_TYPE_NATIVE = 0 + xdrFromEnum ASSET_TYPE_CREDIT_ALPHANUM4 = 1 + xdrFromEnum ASSET_TYPE_CREDIT_ALPHANUM12 = 2 + xdrFromEnum ASSET_TYPE_POOL_SHARE = 3 + xdrToEnum 0 = Prelude.return ASSET_TYPE_NATIVE + xdrToEnum 1 = Prelude.return ASSET_TYPE_CREDIT_ALPHANUM4 + xdrToEnum 2 = Prelude.return ASSET_TYPE_CREDIT_ALPHANUM12 + xdrToEnum 3 = Prelude.return ASSET_TYPE_POOL_SHARE + xdrToEnum _ = Prelude.fail "invalid AssetType" + +data AssetCode = AssetCode'ASSET_TYPE_CREDIT_ALPHANUM4{assetCode'assetCode4 + :: !AssetCode4} + | AssetCode'ASSET_TYPE_CREDIT_ALPHANUM12{assetCode'assetCode12 :: + !AssetCode12} + deriving (Prelude.Eq, Prelude.Show) + +assetCode'type :: AssetCode -> AssetType +assetCode'type = XDR.xdrDiscriminant + +instance XDR.XDR AssetCode where + xdrType _ = "AssetCode" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion AssetCode where + type XDRDiscriminant AssetCode = AssetType + xdrSplitUnion _x@AssetCode'ASSET_TYPE_CREDIT_ALPHANUM4{} + = (1, XDR.xdrPut (assetCode'assetCode4 _x)) + xdrSplitUnion _x@AssetCode'ASSET_TYPE_CREDIT_ALPHANUM12{} + = (2, XDR.xdrPut (assetCode'assetCode12 _x)) + xdrGetUnionArm 1 + = Control.Applicative.pure AssetCode'ASSET_TYPE_CREDIT_ALPHANUM4 + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 2 + = Control.Applicative.pure AssetCode'ASSET_TYPE_CREDIT_ALPHANUM12 + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c = Prelude.fail "invalid AssetCode discriminant" + +data AlphaNum4 = AlphaNum4{alphaNum4'assetCode :: !AssetCode4, + alphaNum4'issuer :: !AccountID} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR AlphaNum4 where + xdrType _ = "AlphaNum4" + xdrPut _x + = XDR.xdrPut (alphaNum4'assetCode _x) Control.Applicative.*> + XDR.xdrPut (alphaNum4'issuer _x) + xdrGet + = Control.Applicative.pure AlphaNum4 Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data AlphaNum12 = AlphaNum12{alphaNum12'assetCode :: !AssetCode12, + alphaNum12'issuer :: !AccountID} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR AlphaNum12 where + xdrType _ = "AlphaNum12" + xdrPut _x + = XDR.xdrPut (alphaNum12'assetCode _x) Control.Applicative.*> + XDR.xdrPut (alphaNum12'issuer _x) + xdrGet + = Control.Applicative.pure AlphaNum12 Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data Asset = Asset'ASSET_TYPE_NATIVE{} + | Asset'ASSET_TYPE_CREDIT_ALPHANUM4{asset'alphaNum4 :: !AlphaNum4} + | Asset'ASSET_TYPE_CREDIT_ALPHANUM12{asset'alphaNum12 :: + !AlphaNum12} + deriving (Prelude.Eq, Prelude.Show) + +asset'type :: Asset -> AssetType +asset'type = XDR.xdrDiscriminant + +instance XDR.XDR Asset where + xdrType _ = "Asset" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion Asset where + type XDRDiscriminant Asset = AssetType + xdrSplitUnion _x@Asset'ASSET_TYPE_NATIVE{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion _x@Asset'ASSET_TYPE_CREDIT_ALPHANUM4{} + = (1, XDR.xdrPut (asset'alphaNum4 _x)) + xdrSplitUnion _x@Asset'ASSET_TYPE_CREDIT_ALPHANUM12{} + = (2, XDR.xdrPut (asset'alphaNum12 _x)) + xdrGetUnionArm 0 = Control.Applicative.pure Asset'ASSET_TYPE_NATIVE + xdrGetUnionArm 1 + = Control.Applicative.pure Asset'ASSET_TYPE_CREDIT_ALPHANUM4 + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 2 + = Control.Applicative.pure Asset'ASSET_TYPE_CREDIT_ALPHANUM12 + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c = Prelude.fail "invalid Asset discriminant" + +data Price = Price{price'n :: !Int32, price'd :: !Int32} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR Price where + xdrType _ = "Price" + xdrPut _x + = XDR.xdrPut (price'n _x) Control.Applicative.*> + XDR.xdrPut (price'd _x) + xdrGet + = Control.Applicative.pure Price Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data ThresholdIndexes = THRESHOLD_MASTER_WEIGHT + | THRESHOLD_LOW + | THRESHOLD_MED + | THRESHOLD_HIGH + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR ThresholdIndexes where + xdrType _ = "ThresholdIndexes" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum ThresholdIndexes where + xdrFromEnum THRESHOLD_MASTER_WEIGHT = 0 + xdrFromEnum THRESHOLD_LOW = 1 + xdrFromEnum THRESHOLD_MED = 2 + xdrFromEnum THRESHOLD_HIGH = 3 + xdrToEnum 0 = Prelude.return THRESHOLD_MASTER_WEIGHT + xdrToEnum 1 = Prelude.return THRESHOLD_LOW + xdrToEnum 2 = Prelude.return THRESHOLD_MED + xdrToEnum 3 = Prelude.return THRESHOLD_HIGH + xdrToEnum _ = Prelude.fail "invalid ThresholdIndexes" + +data LedgerEntryType = ACCOUNT + | TRUSTLINE + | OFFER + | DATA + | CLAIMABLE_BALANCE + | LIQUIDITY_POOL + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR LedgerEntryType where + xdrType _ = "LedgerEntryType" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum LedgerEntryType where + xdrFromEnum ACCOUNT = 0 + xdrFromEnum TRUSTLINE = 1 + xdrFromEnum OFFER = 2 + xdrFromEnum DATA = 3 + xdrFromEnum CLAIMABLE_BALANCE = 4 + xdrFromEnum LIQUIDITY_POOL = 5 + xdrToEnum 0 = Prelude.return ACCOUNT + xdrToEnum 1 = Prelude.return TRUSTLINE + xdrToEnum 2 = Prelude.return OFFER + xdrToEnum 3 = Prelude.return DATA + xdrToEnum 4 = Prelude.return CLAIMABLE_BALANCE + xdrToEnum 5 = Prelude.return LIQUIDITY_POOL + xdrToEnum _ = Prelude.fail "invalid LedgerEntryType" + +data Signer = Signer{signer'key :: !SignerKey, + signer'weight :: !Uint32} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR Signer where + xdrType _ = "Signer" + xdrPut _x + = XDR.xdrPut (signer'key _x) Control.Applicative.*> + XDR.xdrPut (signer'weight _x) + xdrGet + = Control.Applicative.pure Signer Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data AccountFlags = AUTH_REQUIRED_FLAG + | AUTH_REVOCABLE_FLAG + | AUTH_IMMUTABLE_FLAG + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR AccountFlags where + xdrType _ = "AccountFlags" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum AccountFlags where + xdrFromEnum AUTH_REQUIRED_FLAG = 1 + xdrFromEnum AUTH_REVOCABLE_FLAG = 2 + xdrFromEnum AUTH_IMMUTABLE_FLAG = 4 + xdrToEnum 1 = Prelude.return AUTH_REQUIRED_FLAG + xdrToEnum 2 = Prelude.return AUTH_REVOCABLE_FLAG + xdrToEnum 4 = Prelude.return AUTH_IMMUTABLE_FLAG + xdrToEnum _ = Prelude.fail "invalid AccountFlags" + +data AccountEntry = AccountEntry{accountEntry'accountID :: + !AccountID, + accountEntry'balance :: !Int64, + accountEntry'seqNum :: !SequenceNumber, + accountEntry'numSubEntries :: !Uint32, + accountEntry'inflationDest :: !(XDR.Optional AccountID), + accountEntry'flags :: !Uint32, + accountEntry'homeDomain :: !String32, + accountEntry'thresholds :: !Thresholds, + accountEntry'signers :: !(XDR.Array 20 Signer)} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR AccountEntry where + xdrType _ = "AccountEntry" + xdrPut _x + = XDR.xdrPut (accountEntry'accountID _x) Control.Applicative.*> + XDR.xdrPut (accountEntry'balance _x) + Control.Applicative.*> XDR.xdrPut (accountEntry'seqNum _x) + Control.Applicative.*> XDR.xdrPut (accountEntry'numSubEntries _x) + Control.Applicative.*> XDR.xdrPut (accountEntry'inflationDest _x) + Control.Applicative.*> XDR.xdrPut (accountEntry'flags _x) + Control.Applicative.*> XDR.xdrPut (accountEntry'homeDomain _x) + Control.Applicative.*> XDR.xdrPut (accountEntry'thresholds _x) + Control.Applicative.*> XDR.xdrPut (accountEntry'signers _x) + xdrGet + = Control.Applicative.pure AccountEntry Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data TrustLineFlags = AUTHORIZED_FLAG + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR TrustLineFlags where + xdrType _ = "TrustLineFlags" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum TrustLineFlags where + xdrFromEnum AUTHORIZED_FLAG = 1 + xdrToEnum 1 = Prelude.return AUTHORIZED_FLAG + xdrToEnum _ = Prelude.fail "invalid TrustLineFlags" + +data TrustLineAsset = TrustLineAsset'ASSET_TYPE_NATIVE{} + | TrustLineAsset'ASSET_TYPE_CREDIT_ALPHANUM4{trustLineAsset'alphaNum4 + :: !AlphaNum4} + | TrustLineAsset'ASSET_TYPE_CREDIT_ALPHANUM12{trustLineAsset'alphaNum12 + :: !AlphaNum12} + | TrustLineAsset'ASSET_TYPE_POOL_SHARE{trustLineAsset'liquidityPoolID + :: !PoolID} + deriving (Prelude.Eq, Prelude.Show) + +trustLineAsset'type :: TrustLineAsset -> AssetType +trustLineAsset'type = XDR.xdrDiscriminant + +instance XDR.XDR TrustLineAsset where + xdrType _ = "TrustLineAsset" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion TrustLineAsset where + type XDRDiscriminant TrustLineAsset = AssetType + xdrSplitUnion _x@TrustLineAsset'ASSET_TYPE_NATIVE{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion _x@TrustLineAsset'ASSET_TYPE_CREDIT_ALPHANUM4{} + = (1, XDR.xdrPut (trustLineAsset'alphaNum4 _x)) + xdrSplitUnion _x@TrustLineAsset'ASSET_TYPE_CREDIT_ALPHANUM12{} + = (2, XDR.xdrPut (trustLineAsset'alphaNum12 _x)) + xdrSplitUnion _x@TrustLineAsset'ASSET_TYPE_POOL_SHARE{} + = (3, XDR.xdrPut (trustLineAsset'liquidityPoolID _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure TrustLineAsset'ASSET_TYPE_NATIVE + xdrGetUnionArm 1 + = Control.Applicative.pure + TrustLineAsset'ASSET_TYPE_CREDIT_ALPHANUM4 + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 2 + = Control.Applicative.pure + TrustLineAsset'ASSET_TYPE_CREDIT_ALPHANUM12 + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 3 + = Control.Applicative.pure TrustLineAsset'ASSET_TYPE_POOL_SHARE + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = Prelude.fail "invalid TrustLineAsset discriminant" + +data TrustLineEntry = TrustLineEntry{trustLineEntry'accountID :: + !AccountID, + trustLineEntry'asset :: !Asset, + trustLineEntry'balance :: !Int64, + trustLineEntry'limit :: !Int64, + trustLineEntry'flags :: !Uint32} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR TrustLineEntry where + xdrType _ = "TrustLineEntry" + xdrPut _x + = XDR.xdrPut (trustLineEntry'accountID _x) Control.Applicative.*> + XDR.xdrPut (trustLineEntry'asset _x) + Control.Applicative.*> XDR.xdrPut (trustLineEntry'balance _x) + Control.Applicative.*> XDR.xdrPut (trustLineEntry'limit _x) + Control.Applicative.*> XDR.xdrPut (trustLineEntry'flags _x) + xdrGet + = Control.Applicative.pure TrustLineEntry Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data OfferEntryFlags = PASSIVE_FLAG + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR OfferEntryFlags where + xdrType _ = "OfferEntryFlags" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum OfferEntryFlags where + xdrFromEnum PASSIVE_FLAG = 1 + xdrToEnum 1 = Prelude.return PASSIVE_FLAG + xdrToEnum _ = Prelude.fail "invalid OfferEntryFlags" + +data OfferEntry = OfferEntry{offerEntry'sellerID :: !AccountID, + offerEntry'offerID :: !Uint64, offerEntry'selling :: !Asset, + offerEntry'buying :: !Asset, offerEntry'amount :: !Int64, + offerEntry'price :: !Price, offerEntry'flags :: !Uint32} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR OfferEntry where + xdrType _ = "OfferEntry" + xdrPut _x + = XDR.xdrPut (offerEntry'sellerID _x) Control.Applicative.*> + XDR.xdrPut (offerEntry'offerID _x) + Control.Applicative.*> XDR.xdrPut (offerEntry'selling _x) + Control.Applicative.*> XDR.xdrPut (offerEntry'buying _x) + Control.Applicative.*> XDR.xdrPut (offerEntry'amount _x) + Control.Applicative.*> XDR.xdrPut (offerEntry'price _x) + Control.Applicative.*> XDR.xdrPut (offerEntry'flags _x) + xdrGet + = Control.Applicative.pure OfferEntry Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data DataEntry = DataEntry{dataEntry'accountID :: !AccountID, + dataEntry'dataName :: !String64, dataEntry'dataValue :: !DataValue} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR DataEntry where + xdrType _ = "DataEntry" + xdrPut _x + = XDR.xdrPut (dataEntry'accountID _x) Control.Applicative.*> + XDR.xdrPut (dataEntry'dataName _x) + Control.Applicative.*> XDR.xdrPut (dataEntry'dataValue _x) + xdrGet + = Control.Applicative.pure DataEntry Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data ClaimPredicateType = CLAIM_PREDICATE_UNCONDITIONAL + | CLAIM_PREDICATE_AND + | CLAIM_PREDICATE_OR + | CLAIM_PREDICATE_NOT + | CLAIM_PREDICATE_BEFORE_ABSOLUTE_TIME + | CLAIM_PREDICATE_BEFORE_RELATIVE_TIME + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR ClaimPredicateType where + xdrType _ = "ClaimPredicateType" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum ClaimPredicateType where + xdrFromEnum CLAIM_PREDICATE_UNCONDITIONAL = 0 + xdrFromEnum CLAIM_PREDICATE_AND = 1 + xdrFromEnum CLAIM_PREDICATE_OR = 2 + xdrFromEnum CLAIM_PREDICATE_NOT = 3 + xdrFromEnum CLAIM_PREDICATE_BEFORE_ABSOLUTE_TIME = 4 + xdrFromEnum CLAIM_PREDICATE_BEFORE_RELATIVE_TIME = 5 + xdrToEnum 0 = Prelude.return CLAIM_PREDICATE_UNCONDITIONAL + xdrToEnum 1 = Prelude.return CLAIM_PREDICATE_AND + xdrToEnum 2 = Prelude.return CLAIM_PREDICATE_OR + xdrToEnum 3 = Prelude.return CLAIM_PREDICATE_NOT + xdrToEnum 4 = Prelude.return CLAIM_PREDICATE_BEFORE_ABSOLUTE_TIME + xdrToEnum 5 = Prelude.return CLAIM_PREDICATE_BEFORE_RELATIVE_TIME + xdrToEnum _ = Prelude.fail "invalid ClaimPredicateType" + +data ClaimPredicate = ClaimPredicate'CLAIM_PREDICATE_UNCONDITIONAL{} + | ClaimPredicate'CLAIM_PREDICATE_AND{claimPredicate'andPredicates + :: !(XDR.Array 2 ClaimPredicate)} + | ClaimPredicate'CLAIM_PREDICATE_OR{claimPredicate'orPredicates :: + !(XDR.Array 2 ClaimPredicate)} + | ClaimPredicate'CLAIM_PREDICATE_NOT{claimPredicate'notPredicate :: + !(XDR.Optional ClaimPredicate)} + | ClaimPredicate'CLAIM_PREDICATE_BEFORE_ABSOLUTE_TIME{claimPredicate'absBefore + :: !Int64} + | ClaimPredicate'CLAIM_PREDICATE_BEFORE_RELATIVE_TIME{claimPredicate'relBefore + :: !Int64} + deriving (Prelude.Eq, Prelude.Show) + +claimPredicate'type :: ClaimPredicate -> ClaimPredicateType +claimPredicate'type = XDR.xdrDiscriminant + +instance XDR.XDR ClaimPredicate where + xdrType _ = "ClaimPredicate" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion ClaimPredicate where + type XDRDiscriminant ClaimPredicate = ClaimPredicateType + xdrSplitUnion _x@ClaimPredicate'CLAIM_PREDICATE_UNCONDITIONAL{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion _x@ClaimPredicate'CLAIM_PREDICATE_AND{} + = (1, XDR.xdrPut (claimPredicate'andPredicates _x)) + xdrSplitUnion _x@ClaimPredicate'CLAIM_PREDICATE_OR{} + = (2, XDR.xdrPut (claimPredicate'orPredicates _x)) + xdrSplitUnion _x@ClaimPredicate'CLAIM_PREDICATE_NOT{} + = (3, XDR.xdrPut (claimPredicate'notPredicate _x)) + xdrSplitUnion + _x@ClaimPredicate'CLAIM_PREDICATE_BEFORE_ABSOLUTE_TIME{} + = (4, XDR.xdrPut (claimPredicate'absBefore _x)) + xdrSplitUnion + _x@ClaimPredicate'CLAIM_PREDICATE_BEFORE_RELATIVE_TIME{} + = (5, XDR.xdrPut (claimPredicate'relBefore _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure + ClaimPredicate'CLAIM_PREDICATE_UNCONDITIONAL + xdrGetUnionArm 1 + = Control.Applicative.pure ClaimPredicate'CLAIM_PREDICATE_AND + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 2 + = Control.Applicative.pure ClaimPredicate'CLAIM_PREDICATE_OR + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 3 + = Control.Applicative.pure ClaimPredicate'CLAIM_PREDICATE_NOT + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 4 + = Control.Applicative.pure + ClaimPredicate'CLAIM_PREDICATE_BEFORE_ABSOLUTE_TIME + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 5 + = Control.Applicative.pure + ClaimPredicate'CLAIM_PREDICATE_BEFORE_RELATIVE_TIME + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = Prelude.fail "invalid ClaimPredicate discriminant" + +data ClaimantType = CLAIMANT_TYPE_V0 + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR ClaimantType where + xdrType _ = "ClaimantType" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum ClaimantType where + xdrFromEnum CLAIMANT_TYPE_V0 = 0 + xdrToEnum 0 = Prelude.return CLAIMANT_TYPE_V0 + xdrToEnum _ = Prelude.fail "invalid ClaimantType" + +data Claimant = Claimant'CLAIMANT_TYPE_V0{claimant'v0'destination + :: !AccountID, + claimant'v0'predicate :: !ClaimPredicate} + deriving (Prelude.Eq, Prelude.Show) + +claimant'type :: Claimant -> ClaimantType +claimant'type = XDR.xdrDiscriminant + +instance XDR.XDR Claimant where + xdrType _ = "Claimant" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion Claimant where + type XDRDiscriminant Claimant = ClaimantType + xdrSplitUnion _x@Claimant'CLAIMANT_TYPE_V0{} + = (0, + XDR.xdrPut (claimant'v0'destination _x) Control.Applicative.*> + XDR.xdrPut (claimant'v0'predicate _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure Claimant'CLAIMANT_TYPE_V0 + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c = Prelude.fail "invalid Claimant discriminant" + +data ClaimableBalanceIDType = CLAIMABLE_BALANCE_ID_TYPE_V0 + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR ClaimableBalanceIDType where + xdrType _ = "ClaimableBalanceIDType" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum ClaimableBalanceIDType where + xdrFromEnum CLAIMABLE_BALANCE_ID_TYPE_V0 = 0 + xdrToEnum 0 = Prelude.return CLAIMABLE_BALANCE_ID_TYPE_V0 + xdrToEnum _ = Prelude.fail "invalid ClaimableBalanceIDType" + +data ClaimableBalanceID = ClaimableBalanceID'CLAIMABLE_BALANCE_ID_TYPE_V0{claimableBalanceID'v0 + :: !Hash} + deriving (Prelude.Eq, Prelude.Show) + +claimableBalanceID'type :: + ClaimableBalanceID -> ClaimableBalanceIDType +claimableBalanceID'type = XDR.xdrDiscriminant + +instance XDR.XDR ClaimableBalanceID where + xdrType _ = "ClaimableBalanceID" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion ClaimableBalanceID where + type XDRDiscriminant ClaimableBalanceID = ClaimableBalanceIDType + xdrSplitUnion _x@ClaimableBalanceID'CLAIMABLE_BALANCE_ID_TYPE_V0{} + = (0, XDR.xdrPut (claimableBalanceID'v0 _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure + ClaimableBalanceID'CLAIMABLE_BALANCE_ID_TYPE_V0 + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = Prelude.fail "invalid ClaimableBalanceID discriminant" + +data LedgerEntryData = LedgerEntryData'ACCOUNT{ledgerEntryData'account + :: !AccountEntry} + | LedgerEntryData'TRUSTLINE{ledgerEntryData'trustLine :: + !TrustLineEntry} + | LedgerEntryData'OFFER{ledgerEntryData'offer :: !OfferEntry} + | LedgerEntryData'DATA{ledgerEntryData'data :: !DataEntry} + deriving (Prelude.Eq, Prelude.Show) + +ledgerEntryData'type :: LedgerEntryData -> LedgerEntryType +ledgerEntryData'type = XDR.xdrDiscriminant + +instance XDR.XDR LedgerEntryData where + xdrType _ = "LedgerEntryData" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion LedgerEntryData where + type XDRDiscriminant LedgerEntryData = LedgerEntryType + xdrSplitUnion _x@LedgerEntryData'ACCOUNT{} + = (0, XDR.xdrPut (ledgerEntryData'account _x)) + xdrSplitUnion _x@LedgerEntryData'TRUSTLINE{} + = (1, XDR.xdrPut (ledgerEntryData'trustLine _x)) + xdrSplitUnion _x@LedgerEntryData'OFFER{} + = (2, XDR.xdrPut (ledgerEntryData'offer _x)) + xdrSplitUnion _x@LedgerEntryData'DATA{} + = (3, XDR.xdrPut (ledgerEntryData'data _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure LedgerEntryData'ACCOUNT + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 1 + = Control.Applicative.pure LedgerEntryData'TRUSTLINE + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 2 + = Control.Applicative.pure LedgerEntryData'OFFER + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 3 + = Control.Applicative.pure LedgerEntryData'DATA + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = Prelude.fail "invalid LedgerEntryData discriminant" + +data LedgerEntry = LedgerEntry{ledgerEntry'lastModifiedLedgerSeq :: + !Uint32, + ledgerEntry'data :: !LedgerEntryData} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR LedgerEntry where + xdrType _ = "LedgerEntry" + xdrPut _x + = XDR.xdrPut (ledgerEntry'lastModifiedLedgerSeq _x) + Control.Applicative.*> XDR.xdrPut (ledgerEntry'data _x) + xdrGet + = Control.Applicative.pure LedgerEntry Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data LedgerKey = LedgerKey'ACCOUNT{ledgerKey'account'accountID :: + !AccountID} + | LedgerKey'TRUSTLINE{ledgerKey'trustLine'accountID :: !AccountID, + ledgerKey'trustLine'asset :: !TrustLineAsset} + | LedgerKey'OFFER{ledgerKey'offer'sellerID :: !AccountID, + ledgerKey'offer'offerID :: !Int64} + | LedgerKey'DATA{ledgerKey'data'accountID :: !AccountID, + ledgerKey'data'dataName :: !String64} + | LedgerKey'CLAIMABLE_BALANCE{ledgerKey'claimableBalance'balanceID + :: !ClaimableBalanceID} + | LedgerKey'LIQUIDITY_POOL{ledgerKey'liquidityPool'liquidityPoolID + :: !PoolID} + deriving (Prelude.Eq, Prelude.Show) + +ledgerKey'type :: LedgerKey -> LedgerEntryType +ledgerKey'type = XDR.xdrDiscriminant + +instance XDR.XDR LedgerKey where + xdrType _ = "LedgerKey" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion LedgerKey where + type XDRDiscriminant LedgerKey = LedgerEntryType + xdrSplitUnion _x@LedgerKey'ACCOUNT{} + = (0, XDR.xdrPut (ledgerKey'account'accountID _x)) + xdrSplitUnion _x@LedgerKey'TRUSTLINE{} + = (1, + XDR.xdrPut (ledgerKey'trustLine'accountID _x) + Control.Applicative.*> XDR.xdrPut (ledgerKey'trustLine'asset _x)) + xdrSplitUnion _x@LedgerKey'OFFER{} + = (2, + XDR.xdrPut (ledgerKey'offer'sellerID _x) Control.Applicative.*> + XDR.xdrPut (ledgerKey'offer'offerID _x)) + xdrSplitUnion _x@LedgerKey'DATA{} + = (3, + XDR.xdrPut (ledgerKey'data'accountID _x) Control.Applicative.*> + XDR.xdrPut (ledgerKey'data'dataName _x)) + xdrSplitUnion _x@LedgerKey'CLAIMABLE_BALANCE{} + = (4, XDR.xdrPut (ledgerKey'claimableBalance'balanceID _x)) + xdrSplitUnion _x@LedgerKey'LIQUIDITY_POOL{} + = (5, XDR.xdrPut (ledgerKey'liquidityPool'liquidityPoolID _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure LedgerKey'ACCOUNT + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 1 + = Control.Applicative.pure LedgerKey'TRUSTLINE + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 2 + = Control.Applicative.pure LedgerKey'OFFER Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 3 + = Control.Applicative.pure LedgerKey'DATA Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 4 + = Control.Applicative.pure LedgerKey'CLAIMABLE_BALANCE + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 5 + = Control.Applicative.pure LedgerKey'LIQUIDITY_POOL + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c = Prelude.fail "invalid LedgerKey discriminant" + +data EnvelopeType = ENVELOPE_TYPE_TX_V0 + | ENVELOPE_TYPE_SCP + | ENVELOPE_TYPE_TX + | ENVELOPE_TYPE_AUTH + | ENVELOPE_TYPE_SCPVALUE + | ENVELOPE_TYPE_TX_FEE_BUMP + | ENVELOPE_TYPE_OP_ID + | ENVELOPE_TYPE_POOL_REVOKE_OP_ID + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR EnvelopeType where + xdrType _ = "EnvelopeType" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum EnvelopeType where + xdrFromEnum ENVELOPE_TYPE_TX_V0 = 0 + xdrFromEnum ENVELOPE_TYPE_SCP = 1 + xdrFromEnum ENVELOPE_TYPE_TX = 2 + xdrFromEnum ENVELOPE_TYPE_AUTH = 3 + xdrFromEnum ENVELOPE_TYPE_SCPVALUE = 4 + xdrFromEnum ENVELOPE_TYPE_TX_FEE_BUMP = 5 + xdrFromEnum ENVELOPE_TYPE_OP_ID = 6 + xdrFromEnum ENVELOPE_TYPE_POOL_REVOKE_OP_ID = 7 + xdrToEnum 0 = Prelude.return ENVELOPE_TYPE_TX_V0 + xdrToEnum 1 = Prelude.return ENVELOPE_TYPE_SCP + xdrToEnum 2 = Prelude.return ENVELOPE_TYPE_TX + xdrToEnum 3 = Prelude.return ENVELOPE_TYPE_AUTH + xdrToEnum 4 = Prelude.return ENVELOPE_TYPE_SCPVALUE + xdrToEnum 5 = Prelude.return ENVELOPE_TYPE_TX_FEE_BUMP + xdrToEnum 6 = Prelude.return ENVELOPE_TYPE_OP_ID + xdrToEnum 7 = Prelude.return ENVELOPE_TYPE_POOL_REVOKE_OP_ID + xdrToEnum _ = Prelude.fail "invalid EnvelopeType" + +data DecoratedSignature = DecoratedSignature{decoratedSignature'hint + :: !SignatureHint, + decoratedSignature'signature :: !Signature} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR DecoratedSignature where + xdrType _ = "DecoratedSignature" + xdrPut _x + = XDR.xdrPut (decoratedSignature'hint _x) Control.Applicative.*> + XDR.xdrPut (decoratedSignature'signature _x) + xdrGet + = Control.Applicative.pure DecoratedSignature + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data OperationType = CREATE_ACCOUNT + | PAYMENT + | PATH_PAYMENT_STRICT_RECEIVE + | MANAGE_SELL_OFFER + | CREATE_PASSIVE_SELL_OFFER + | SET_OPTIONS + | CHANGE_TRUST + | ALLOW_TRUST + | ACCOUNT_MERGE + | INFLATION + | MANAGE_DATA + | BUMP_SEQUENCE + | MANAGE_BUY_OFFER + | PATH_PAYMENT_STRICT_SEND + | CREATE_CLAIMABLE_BALANCE + | CLAIM_CLAIMABLE_BALANCE + | BEGIN_SPONSORING_FUTURE_RESERVES + | END_SPONSORING_FUTURE_RESERVES + | REVOKE_SPONSORSHIP + | CLAWBACK + | CLAWBACK_CLAIMABLE_BALANCE + | SET_TRUST_LINE_FLAGS + | LIQUIDITY_POOL_DEPOSIT + | LIQUIDITY_POOL_WITHDRAW + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR OperationType where + xdrType _ = "OperationType" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum OperationType where + xdrFromEnum CREATE_ACCOUNT = 0 + xdrFromEnum PAYMENT = 1 + xdrFromEnum PATH_PAYMENT_STRICT_RECEIVE = 2 + xdrFromEnum MANAGE_SELL_OFFER = 3 + xdrFromEnum CREATE_PASSIVE_SELL_OFFER = 4 + xdrFromEnum SET_OPTIONS = 5 + xdrFromEnum CHANGE_TRUST = 6 + xdrFromEnum ALLOW_TRUST = 7 + xdrFromEnum ACCOUNT_MERGE = 8 + xdrFromEnum INFLATION = 9 + xdrFromEnum MANAGE_DATA = 10 + xdrFromEnum BUMP_SEQUENCE = 11 + xdrFromEnum MANAGE_BUY_OFFER = 12 + xdrFromEnum PATH_PAYMENT_STRICT_SEND = 13 + xdrFromEnum CREATE_CLAIMABLE_BALANCE = 14 + xdrFromEnum CLAIM_CLAIMABLE_BALANCE = 15 + xdrFromEnum BEGIN_SPONSORING_FUTURE_RESERVES = 16 + xdrFromEnum END_SPONSORING_FUTURE_RESERVES = 17 + xdrFromEnum REVOKE_SPONSORSHIP = 18 + xdrFromEnum CLAWBACK = 19 + xdrFromEnum CLAWBACK_CLAIMABLE_BALANCE = 20 + xdrFromEnum SET_TRUST_LINE_FLAGS = 21 + xdrFromEnum LIQUIDITY_POOL_DEPOSIT = 22 + xdrFromEnum LIQUIDITY_POOL_WITHDRAW = 23 + xdrToEnum 0 = Prelude.return CREATE_ACCOUNT + xdrToEnum 1 = Prelude.return PAYMENT + xdrToEnum 2 = Prelude.return PATH_PAYMENT_STRICT_RECEIVE + xdrToEnum 3 = Prelude.return MANAGE_SELL_OFFER + xdrToEnum 4 = Prelude.return CREATE_PASSIVE_SELL_OFFER + xdrToEnum 5 = Prelude.return SET_OPTIONS + xdrToEnum 6 = Prelude.return CHANGE_TRUST + xdrToEnum 7 = Prelude.return ALLOW_TRUST + xdrToEnum 8 = Prelude.return ACCOUNT_MERGE + xdrToEnum 9 = Prelude.return INFLATION + xdrToEnum 10 = Prelude.return MANAGE_DATA + xdrToEnum 11 = Prelude.return BUMP_SEQUENCE + xdrToEnum 12 = Prelude.return MANAGE_BUY_OFFER + xdrToEnum 13 = Prelude.return PATH_PAYMENT_STRICT_SEND + xdrToEnum 14 = Prelude.return CREATE_CLAIMABLE_BALANCE + xdrToEnum 15 = Prelude.return CLAIM_CLAIMABLE_BALANCE + xdrToEnum 16 = Prelude.return BEGIN_SPONSORING_FUTURE_RESERVES + xdrToEnum 17 = Prelude.return END_SPONSORING_FUTURE_RESERVES + xdrToEnum 18 = Prelude.return REVOKE_SPONSORSHIP + xdrToEnum 19 = Prelude.return CLAWBACK + xdrToEnum 20 = Prelude.return CLAWBACK_CLAIMABLE_BALANCE + xdrToEnum 21 = Prelude.return SET_TRUST_LINE_FLAGS + xdrToEnum 22 = Prelude.return LIQUIDITY_POOL_DEPOSIT + xdrToEnum 23 = Prelude.return LIQUIDITY_POOL_WITHDRAW + xdrToEnum _ = Prelude.fail "invalid OperationType" + +data CreateAccountOp = CreateAccountOp{createAccountOp'destination + :: !AccountID, + createAccountOp'startingBalance :: !Int64} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR CreateAccountOp where + xdrType _ = "CreateAccountOp" + xdrPut _x + = XDR.xdrPut (createAccountOp'destination _x) + Control.Applicative.*> + XDR.xdrPut (createAccountOp'startingBalance _x) + xdrGet + = Control.Applicative.pure CreateAccountOp Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data PaymentOp = PaymentOp{paymentOp'destination :: !MuxedAccount, + paymentOp'asset :: !Asset, paymentOp'amount :: !Int64} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR PaymentOp where + xdrType _ = "PaymentOp" + xdrPut _x + = XDR.xdrPut (paymentOp'destination _x) Control.Applicative.*> + XDR.xdrPut (paymentOp'asset _x) + Control.Applicative.*> XDR.xdrPut (paymentOp'amount _x) + xdrGet + = Control.Applicative.pure PaymentOp Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data PathPaymentStrictReceiveOp = PathPaymentStrictReceiveOp{pathPaymentStrictReceiveOp'sendAsset + :: !Asset, + pathPaymentStrictReceiveOp'sendMax :: + !Int64, + pathPaymentStrictReceiveOp'destination + :: !MuxedAccount, + pathPaymentStrictReceiveOp'destAsset :: + !Asset, + pathPaymentStrictReceiveOp'destAmount + :: !Int64, + pathPaymentStrictReceiveOp'path :: + !(XDR.Array 5 Asset)} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR PathPaymentStrictReceiveOp where + xdrType _ = "PathPaymentStrictReceiveOp" + xdrPut _x + = XDR.xdrPut (pathPaymentStrictReceiveOp'sendAsset _x) + Control.Applicative.*> + XDR.xdrPut (pathPaymentStrictReceiveOp'sendMax _x) + Control.Applicative.*> + XDR.xdrPut (pathPaymentStrictReceiveOp'destination _x) + Control.Applicative.*> + XDR.xdrPut (pathPaymentStrictReceiveOp'destAsset _x) + Control.Applicative.*> + XDR.xdrPut (pathPaymentStrictReceiveOp'destAmount _x) + Control.Applicative.*> + XDR.xdrPut (pathPaymentStrictReceiveOp'path _x) + xdrGet + = Control.Applicative.pure PathPaymentStrictReceiveOp + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data PathPaymentStrictSendOp = PathPaymentStrictSendOp{pathPaymentStrictSendOp'sendAsset + :: !Asset, + pathPaymentStrictSendOp'sendAmount :: !Int64, + pathPaymentStrictSendOp'destination :: + !MuxedAccount, + pathPaymentStrictSendOp'destAsset :: !Asset, + pathPaymentStrictSendOp'destMin :: !Int64, + pathPaymentStrictSendOp'path :: + !(XDR.Array 5 Asset)} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR PathPaymentStrictSendOp where + xdrType _ = "PathPaymentStrictSendOp" + xdrPut _x + = XDR.xdrPut (pathPaymentStrictSendOp'sendAsset _x) + Control.Applicative.*> + XDR.xdrPut (pathPaymentStrictSendOp'sendAmount _x) + Control.Applicative.*> + XDR.xdrPut (pathPaymentStrictSendOp'destination _x) + Control.Applicative.*> + XDR.xdrPut (pathPaymentStrictSendOp'destAsset _x) + Control.Applicative.*> + XDR.xdrPut (pathPaymentStrictSendOp'destMin _x) + Control.Applicative.*> XDR.xdrPut (pathPaymentStrictSendOp'path _x) + xdrGet + = Control.Applicative.pure PathPaymentStrictSendOp + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data ManageSellOfferOp = ManageSellOfferOp{manageSellOfferOp'selling + :: !Asset, + manageSellOfferOp'buying :: !Asset, + manageSellOfferOp'amount :: !Int64, + manageSellOfferOp'price :: !Price, + manageSellOfferOp'offerID :: !Int64} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR ManageSellOfferOp where + xdrType _ = "ManageSellOfferOp" + xdrPut _x + = XDR.xdrPut (manageSellOfferOp'selling _x) Control.Applicative.*> + XDR.xdrPut (manageSellOfferOp'buying _x) + Control.Applicative.*> XDR.xdrPut (manageSellOfferOp'amount _x) + Control.Applicative.*> XDR.xdrPut (manageSellOfferOp'price _x) + Control.Applicative.*> XDR.xdrPut (manageSellOfferOp'offerID _x) + xdrGet + = Control.Applicative.pure ManageSellOfferOp + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data ManageBuyOfferOp = ManageBuyOfferOp{manageBuyOfferOp'selling + :: !Asset, + manageBuyOfferOp'buying :: !Asset, + manageBuyOfferOp'buyAmount :: !Int64, + manageBuyOfferOp'price :: !Price, + manageBuyOfferOp'offerID :: !Int64} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR ManageBuyOfferOp where + xdrType _ = "ManageBuyOfferOp" + xdrPut _x + = XDR.xdrPut (manageBuyOfferOp'selling _x) Control.Applicative.*> + XDR.xdrPut (manageBuyOfferOp'buying _x) + Control.Applicative.*> XDR.xdrPut (manageBuyOfferOp'buyAmount _x) + Control.Applicative.*> XDR.xdrPut (manageBuyOfferOp'price _x) + Control.Applicative.*> XDR.xdrPut (manageBuyOfferOp'offerID _x) + xdrGet + = Control.Applicative.pure ManageBuyOfferOp Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data CreatePassiveSellOfferOp = CreatePassiveSellOfferOp{createPassiveSellOfferOp'selling + :: !Asset, + createPassiveSellOfferOp'buying :: !Asset, + createPassiveSellOfferOp'amount :: !Int64, + createPassiveSellOfferOp'price :: !Price} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR CreatePassiveSellOfferOp where + xdrType _ = "CreatePassiveSellOfferOp" + xdrPut _x + = XDR.xdrPut (createPassiveSellOfferOp'selling _x) + Control.Applicative.*> + XDR.xdrPut (createPassiveSellOfferOp'buying _x) + Control.Applicative.*> + XDR.xdrPut (createPassiveSellOfferOp'amount _x) + Control.Applicative.*> + XDR.xdrPut (createPassiveSellOfferOp'price _x) + xdrGet + = Control.Applicative.pure CreatePassiveSellOfferOp + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data SetOptionsOp = SetOptionsOp{setOptionsOp'inflationDest :: + !(XDR.Optional AccountID), + setOptionsOp'clearFlags :: !(XDR.Optional Uint32), + setOptionsOp'setFlags :: !(XDR.Optional Uint32), + setOptionsOp'masterWeight :: !(XDR.Optional Uint32), + setOptionsOp'lowThreshold :: !(XDR.Optional Uint32), + setOptionsOp'medThreshold :: !(XDR.Optional Uint32), + setOptionsOp'highThreshold :: !(XDR.Optional Uint32), + setOptionsOp'homeDomain :: !(XDR.Optional String32), + setOptionsOp'signer :: !(XDR.Optional Signer)} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR SetOptionsOp where + xdrType _ = "SetOptionsOp" + xdrPut _x + = XDR.xdrPut (setOptionsOp'inflationDest _x) Control.Applicative.*> + XDR.xdrPut (setOptionsOp'clearFlags _x) + Control.Applicative.*> XDR.xdrPut (setOptionsOp'setFlags _x) + Control.Applicative.*> XDR.xdrPut (setOptionsOp'masterWeight _x) + Control.Applicative.*> XDR.xdrPut (setOptionsOp'lowThreshold _x) + Control.Applicative.*> XDR.xdrPut (setOptionsOp'medThreshold _x) + Control.Applicative.*> XDR.xdrPut (setOptionsOp'highThreshold _x) + Control.Applicative.*> XDR.xdrPut (setOptionsOp'homeDomain _x) + Control.Applicative.*> XDR.xdrPut (setOptionsOp'signer _x) + xdrGet + = Control.Applicative.pure SetOptionsOp Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data ChangeTrustOp = ChangeTrustOp{changeTrustOp'line :: !Asset, + changeTrustOp'limit :: !Int64} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR ChangeTrustOp where + xdrType _ = "ChangeTrustOp" + xdrPut _x + = XDR.xdrPut (changeTrustOp'line _x) Control.Applicative.*> + XDR.xdrPut (changeTrustOp'limit _x) + xdrGet + = Control.Applicative.pure ChangeTrustOp Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data AllowTrustOpAsset = AllowTrustOpAsset'ASSET_TYPE_CREDIT_ALPHANUM4{allowTrustOpAsset'assetCode4 + :: !(XDR.FixedOpaque 4)} + | AllowTrustOpAsset'ASSET_TYPE_CREDIT_ALPHANUM12{allowTrustOpAsset'assetCode12 + :: !(XDR.FixedOpaque 12)} + deriving (Prelude.Eq, Prelude.Show) + +allowTrustOpAsset'type :: AllowTrustOpAsset -> AssetType +allowTrustOpAsset'type = XDR.xdrDiscriminant + +instance XDR.XDR AllowTrustOpAsset where + xdrType _ = "AllowTrustOpAsset" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion AllowTrustOpAsset where + type XDRDiscriminant AllowTrustOpAsset = AssetType + xdrSplitUnion _x@AllowTrustOpAsset'ASSET_TYPE_CREDIT_ALPHANUM4{} + = (1, XDR.xdrPut (allowTrustOpAsset'assetCode4 _x)) + xdrSplitUnion _x@AllowTrustOpAsset'ASSET_TYPE_CREDIT_ALPHANUM12{} + = (2, XDR.xdrPut (allowTrustOpAsset'assetCode12 _x)) + xdrGetUnionArm 1 + = Control.Applicative.pure + AllowTrustOpAsset'ASSET_TYPE_CREDIT_ALPHANUM4 + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 2 + = Control.Applicative.pure + AllowTrustOpAsset'ASSET_TYPE_CREDIT_ALPHANUM12 + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = Prelude.fail "invalid AllowTrustOpAsset discriminant" + +data AllowTrustOp = AllowTrustOp{allowTrustOp'trustor :: + !AccountID, + allowTrustOp'asset :: !AllowTrustOpAsset, + allowTrustOp'authorize :: !XDR.Bool} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR AllowTrustOp where + xdrType _ = "AllowTrustOp" + xdrPut _x + = XDR.xdrPut (allowTrustOp'trustor _x) Control.Applicative.*> + XDR.xdrPut (allowTrustOp'asset _x) + Control.Applicative.*> XDR.xdrPut (allowTrustOp'authorize _x) + xdrGet + = Control.Applicative.pure AllowTrustOp Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data ManageDataOp = ManageDataOp{manageDataOp'dataName :: + !String64, + manageDataOp'dataValue :: !(XDR.Optional DataValue)} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR ManageDataOp where + xdrType _ = "ManageDataOp" + xdrPut _x + = XDR.xdrPut (manageDataOp'dataName _x) Control.Applicative.*> + XDR.xdrPut (manageDataOp'dataValue _x) + xdrGet + = Control.Applicative.pure ManageDataOp Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data BumpSequenceOp = BumpSequenceOp{bumpSequenceOp'bumpTo :: + !SequenceNumber} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR BumpSequenceOp where + xdrType _ = "BumpSequenceOp" + xdrPut _x = XDR.xdrPut (bumpSequenceOp'bumpTo _x) + xdrGet + = Control.Applicative.pure BumpSequenceOp Control.Applicative.<*> + XDR.xdrGet + +data CreateClaimableBalanceOp = CreateClaimableBalanceOp{createClaimableBalanceOp'asset + :: !Asset, + createClaimableBalanceOp'amount :: !Int64, + createClaimableBalanceOp'claimants :: + !(XDR.Array 10 Claimant)} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR CreateClaimableBalanceOp where + xdrType _ = "CreateClaimableBalanceOp" + xdrPut _x + = XDR.xdrPut (createClaimableBalanceOp'asset _x) + Control.Applicative.*> + XDR.xdrPut (createClaimableBalanceOp'amount _x) + Control.Applicative.*> + XDR.xdrPut (createClaimableBalanceOp'claimants _x) + xdrGet + = Control.Applicative.pure CreateClaimableBalanceOp + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data ClaimClaimableBalanceOp = ClaimClaimableBalanceOp{claimClaimableBalanceOp'balanceID + :: !ClaimableBalanceID} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR ClaimClaimableBalanceOp where + xdrType _ = "ClaimClaimableBalanceOp" + xdrPut _x = XDR.xdrPut (claimClaimableBalanceOp'balanceID _x) + xdrGet + = Control.Applicative.pure ClaimClaimableBalanceOp + Control.Applicative.<*> XDR.xdrGet + +data BeginSponsoringFutureReservesOp = BeginSponsoringFutureReservesOp{beginSponsoringFutureReservesOp'sponsoredID + :: !AccountID} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR BeginSponsoringFutureReservesOp where + xdrType _ = "BeginSponsoringFutureReservesOp" + xdrPut _x + = XDR.xdrPut (beginSponsoringFutureReservesOp'sponsoredID _x) + xdrGet + = Control.Applicative.pure BeginSponsoringFutureReservesOp + Control.Applicative.<*> XDR.xdrGet + +data RevokeSponsorshipType = REVOKE_SPONSORSHIP_LEDGER_ENTRY + | REVOKE_SPONSORSHIP_SIGNER + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR RevokeSponsorshipType where + xdrType _ = "RevokeSponsorshipType" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum RevokeSponsorshipType where + xdrFromEnum REVOKE_SPONSORSHIP_LEDGER_ENTRY = 0 + xdrFromEnum REVOKE_SPONSORSHIP_SIGNER = 1 + xdrToEnum 0 = Prelude.return REVOKE_SPONSORSHIP_LEDGER_ENTRY + xdrToEnum 1 = Prelude.return REVOKE_SPONSORSHIP_SIGNER + xdrToEnum _ = Prelude.fail "invalid RevokeSponsorshipType" + +data RevokeSponsorshipOp = RevokeSponsorshipOp'REVOKE_SPONSORSHIP_LEDGER_ENTRY{revokeSponsorshipOp'ledgerKey + :: !LedgerKey} + | RevokeSponsorshipOp'REVOKE_SPONSORSHIP_SIGNER{revokeSponsorshipOp'signer'accountID + :: !AccountID, + revokeSponsorshipOp'signer'signerKey + :: !SignerKey} + deriving (Prelude.Eq, Prelude.Show) + +revokeSponsorshipOp'type :: + RevokeSponsorshipOp -> RevokeSponsorshipType +revokeSponsorshipOp'type = XDR.xdrDiscriminant + +instance XDR.XDR RevokeSponsorshipOp where + xdrType _ = "RevokeSponsorshipOp" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion RevokeSponsorshipOp where + type XDRDiscriminant RevokeSponsorshipOp = RevokeSponsorshipType + xdrSplitUnion + _x@RevokeSponsorshipOp'REVOKE_SPONSORSHIP_LEDGER_ENTRY{} + = (0, XDR.xdrPut (revokeSponsorshipOp'ledgerKey _x)) + xdrSplitUnion _x@RevokeSponsorshipOp'REVOKE_SPONSORSHIP_SIGNER{} + = (1, + XDR.xdrPut (revokeSponsorshipOp'signer'accountID _x) + Control.Applicative.*> + XDR.xdrPut (revokeSponsorshipOp'signer'signerKey _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure + RevokeSponsorshipOp'REVOKE_SPONSORSHIP_LEDGER_ENTRY + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 1 + = Control.Applicative.pure + RevokeSponsorshipOp'REVOKE_SPONSORSHIP_SIGNER + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = Prelude.fail "invalid RevokeSponsorshipOp discriminant" + +data ClawbackOp = ClawbackOp{clawbackOp'asset :: !Asset, + clawbackOp'from :: !MuxedAccount, clawbackOp'amount :: !Int64} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR ClawbackOp where + xdrType _ = "ClawbackOp" + xdrPut _x + = XDR.xdrPut (clawbackOp'asset _x) Control.Applicative.*> + XDR.xdrPut (clawbackOp'from _x) + Control.Applicative.*> XDR.xdrPut (clawbackOp'amount _x) + xdrGet + = Control.Applicative.pure ClawbackOp Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data ClawbackClaimableBalanceOp = ClawbackClaimableBalanceOp{clawbackClaimableBalanceOp'balanceID + :: !ClaimableBalanceID} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR ClawbackClaimableBalanceOp where + xdrType _ = "ClawbackClaimableBalanceOp" + xdrPut _x = XDR.xdrPut (clawbackClaimableBalanceOp'balanceID _x) + xdrGet + = Control.Applicative.pure ClawbackClaimableBalanceOp + Control.Applicative.<*> XDR.xdrGet + +data SetTrustLineFlagsOp = SetTrustLineFlagsOp{setTrustLineFlagsOp'trustor + :: !AccountID, + setTrustLineFlagsOp'asset :: !Asset, + setTrustLineFlagsOp'clearFlags :: !Uint32, + setTrustLineFlagsOp'setFlags :: !Uint32} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR SetTrustLineFlagsOp where + xdrType _ = "SetTrustLineFlagsOp" + xdrPut _x + = XDR.xdrPut (setTrustLineFlagsOp'trustor _x) + Control.Applicative.*> XDR.xdrPut (setTrustLineFlagsOp'asset _x) + Control.Applicative.*> + XDR.xdrPut (setTrustLineFlagsOp'clearFlags _x) + Control.Applicative.*> XDR.xdrPut (setTrustLineFlagsOp'setFlags _x) + xdrGet + = Control.Applicative.pure SetTrustLineFlagsOp + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +lIQUIDITY_POOL_FEE_V18 :: Prelude.Integral a => a +lIQUIDITY_POOL_FEE_V18 = 30 + +data LiquidityPoolDepositOp = LiquidityPoolDepositOp{liquidityPoolDepositOp'liquidityPoolID + :: !PoolID, + liquidityPoolDepositOp'maxAmountA :: !Int64, + liquidityPoolDepositOp'maxAmountB :: !Int64, + liquidityPoolDepositOp'minPrice :: !Price, + liquidityPoolDepositOp'maxPrice :: !Price} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR LiquidityPoolDepositOp where + xdrType _ = "LiquidityPoolDepositOp" + xdrPut _x + = XDR.xdrPut (liquidityPoolDepositOp'liquidityPoolID _x) + Control.Applicative.*> + XDR.xdrPut (liquidityPoolDepositOp'maxAmountA _x) + Control.Applicative.*> + XDR.xdrPut (liquidityPoolDepositOp'maxAmountB _x) + Control.Applicative.*> + XDR.xdrPut (liquidityPoolDepositOp'minPrice _x) + Control.Applicative.*> + XDR.xdrPut (liquidityPoolDepositOp'maxPrice _x) + xdrGet + = Control.Applicative.pure LiquidityPoolDepositOp + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data LiquidityPoolWithdrawOp = LiquidityPoolWithdrawOp{liquidityPoolWithdrawOp'liquidityPoolID + :: !PoolID, + liquidityPoolWithdrawOp'amount :: !Int64, + liquidityPoolWithdrawOp'minAmountA :: !Int64, + liquidityPoolWithdrawOp'minAmountB :: !Int64} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR LiquidityPoolWithdrawOp where + xdrType _ = "LiquidityPoolWithdrawOp" + xdrPut _x + = XDR.xdrPut (liquidityPoolWithdrawOp'liquidityPoolID _x) + Control.Applicative.*> + XDR.xdrPut (liquidityPoolWithdrawOp'amount _x) + Control.Applicative.*> + XDR.xdrPut (liquidityPoolWithdrawOp'minAmountA _x) + Control.Applicative.*> + XDR.xdrPut (liquidityPoolWithdrawOp'minAmountB _x) + xdrGet + = Control.Applicative.pure LiquidityPoolWithdrawOp + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data OperationBody = OperationBody'CREATE_ACCOUNT{operationBody'createAccountOp + :: !CreateAccountOp} + | OperationBody'PAYMENT{operationBody'paymentOp :: !PaymentOp} + | OperationBody'PATH_PAYMENT_STRICT_RECEIVE{operationBody'pathPaymentStrictReceiveOp + :: !PathPaymentStrictReceiveOp} + | OperationBody'MANAGE_SELL_OFFER{operationBody'manageSellOfferOp + :: !ManageSellOfferOp} + | OperationBody'CREATE_PASSIVE_SELL_OFFER{operationBody'createPassiveSellOfferOp + :: !CreatePassiveSellOfferOp} + | OperationBody'SET_OPTIONS{operationBody'setOptionsOp :: + !SetOptionsOp} + | OperationBody'CHANGE_TRUST{operationBody'changeTrustOp :: + !ChangeTrustOp} + | OperationBody'ALLOW_TRUST{operationBody'allowTrustOp :: + !AllowTrustOp} + | OperationBody'ACCOUNT_MERGE{operationBody'destination :: + !MuxedAccount} + | OperationBody'INFLATION{} + | OperationBody'MANAGE_DATA{operationBody'manageDataOp :: + !ManageDataOp} + | OperationBody'BUMP_SEQUENCE{operationBody'bumpSequenceOp :: + !BumpSequenceOp} + | OperationBody'MANAGE_BUY_OFFER{operationBody'manageBuyOfferOp :: + !ManageBuyOfferOp} + | OperationBody'PATH_PAYMENT_STRICT_SEND{operationBody'pathPaymentStrictSendOp + :: !PathPaymentStrictSendOp} + | OperationBody'CREATE_CLAIMABLE_BALANCE{operationBody'createClaimableBalanceOp + :: !CreateClaimableBalanceOp} + | OperationBody'CLAIM_CLAIMABLE_BALANCE{operationBody'claimClaimableBalanceOp + :: !ClaimClaimableBalanceOp} + | OperationBody'BEGIN_SPONSORING_FUTURE_RESERVES{operationBody'beginSponsoringFutureReservesOp + :: + !BeginSponsoringFutureReservesOp} + | OperationBody'END_SPONSORING_FUTURE_RESERVES{} + | OperationBody'REVOKE_SPONSORSHIP{operationBody'revokeSponsorshipOp + :: !RevokeSponsorshipOp} + | OperationBody'CLAWBACK{operationBody'clawbackOp :: !ClawbackOp} + | OperationBody'CLAWBACK_CLAIMABLE_BALANCE{operationBody'clawbackClaimableBalanceOp + :: !ClawbackClaimableBalanceOp} + | OperationBody'SET_TRUST_LINE_FLAGS{operationBody'setTrustLineFlagsOp + :: !SetTrustLineFlagsOp} + | OperationBody'LIQUIDITY_POOL_DEPOSIT{operationBody'liquidityPoolDepositOp + :: !LiquidityPoolDepositOp} + | OperationBody'LIQUIDITY_POOL_WITHDRAW{operationBody'liquidityPoolWithdrawOp + :: !LiquidityPoolWithdrawOp} + deriving (Prelude.Eq, Prelude.Show) + +operationBody'type :: OperationBody -> OperationType +operationBody'type = XDR.xdrDiscriminant + +instance XDR.XDR OperationBody where + xdrType _ = "OperationBody" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion OperationBody where + type XDRDiscriminant OperationBody = OperationType + xdrSplitUnion _x@OperationBody'CREATE_ACCOUNT{} + = (0, XDR.xdrPut (operationBody'createAccountOp _x)) + xdrSplitUnion _x@OperationBody'PAYMENT{} + = (1, XDR.xdrPut (operationBody'paymentOp _x)) + xdrSplitUnion _x@OperationBody'PATH_PAYMENT_STRICT_RECEIVE{} + = (2, XDR.xdrPut (operationBody'pathPaymentStrictReceiveOp _x)) + xdrSplitUnion _x@OperationBody'MANAGE_SELL_OFFER{} + = (3, XDR.xdrPut (operationBody'manageSellOfferOp _x)) + xdrSplitUnion _x@OperationBody'CREATE_PASSIVE_SELL_OFFER{} + = (4, XDR.xdrPut (operationBody'createPassiveSellOfferOp _x)) + xdrSplitUnion _x@OperationBody'SET_OPTIONS{} + = (5, XDR.xdrPut (operationBody'setOptionsOp _x)) + xdrSplitUnion _x@OperationBody'CHANGE_TRUST{} + = (6, XDR.xdrPut (operationBody'changeTrustOp _x)) + xdrSplitUnion _x@OperationBody'ALLOW_TRUST{} + = (7, XDR.xdrPut (operationBody'allowTrustOp _x)) + xdrSplitUnion _x@OperationBody'ACCOUNT_MERGE{} + = (8, XDR.xdrPut (operationBody'destination _x)) + xdrSplitUnion _x@OperationBody'INFLATION{} + = (9, Control.Applicative.pure ()) + xdrSplitUnion _x@OperationBody'MANAGE_DATA{} + = (10, XDR.xdrPut (operationBody'manageDataOp _x)) + xdrSplitUnion _x@OperationBody'BUMP_SEQUENCE{} + = (11, XDR.xdrPut (operationBody'bumpSequenceOp _x)) + xdrSplitUnion _x@OperationBody'MANAGE_BUY_OFFER{} + = (12, XDR.xdrPut (operationBody'manageBuyOfferOp _x)) + xdrSplitUnion _x@OperationBody'PATH_PAYMENT_STRICT_SEND{} + = (13, XDR.xdrPut (operationBody'pathPaymentStrictSendOp _x)) + xdrSplitUnion _x@OperationBody'CREATE_CLAIMABLE_BALANCE{} + = (14, XDR.xdrPut (operationBody'createClaimableBalanceOp _x)) + xdrSplitUnion _x@OperationBody'CLAIM_CLAIMABLE_BALANCE{} + = (15, XDR.xdrPut (operationBody'claimClaimableBalanceOp _x)) + xdrSplitUnion _x@OperationBody'BEGIN_SPONSORING_FUTURE_RESERVES{} + = (16, + XDR.xdrPut (operationBody'beginSponsoringFutureReservesOp _x)) + xdrSplitUnion _x@OperationBody'END_SPONSORING_FUTURE_RESERVES{} + = (17, Control.Applicative.pure ()) + xdrSplitUnion _x@OperationBody'REVOKE_SPONSORSHIP{} + = (18, XDR.xdrPut (operationBody'revokeSponsorshipOp _x)) + xdrSplitUnion _x@OperationBody'CLAWBACK{} + = (19, XDR.xdrPut (operationBody'clawbackOp _x)) + xdrSplitUnion _x@OperationBody'CLAWBACK_CLAIMABLE_BALANCE{} + = (20, XDR.xdrPut (operationBody'clawbackClaimableBalanceOp _x)) + xdrSplitUnion _x@OperationBody'SET_TRUST_LINE_FLAGS{} + = (21, XDR.xdrPut (operationBody'setTrustLineFlagsOp _x)) + xdrSplitUnion _x@OperationBody'LIQUIDITY_POOL_DEPOSIT{} + = (22, XDR.xdrPut (operationBody'liquidityPoolDepositOp _x)) + xdrSplitUnion _x@OperationBody'LIQUIDITY_POOL_WITHDRAW{} + = (23, XDR.xdrPut (operationBody'liquidityPoolWithdrawOp _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure OperationBody'CREATE_ACCOUNT + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 1 + = Control.Applicative.pure OperationBody'PAYMENT + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 2 + = Control.Applicative.pure + OperationBody'PATH_PAYMENT_STRICT_RECEIVE + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 3 + = Control.Applicative.pure OperationBody'MANAGE_SELL_OFFER + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 4 + = Control.Applicative.pure OperationBody'CREATE_PASSIVE_SELL_OFFER + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 5 + = Control.Applicative.pure OperationBody'SET_OPTIONS + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 6 + = Control.Applicative.pure OperationBody'CHANGE_TRUST + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 7 + = Control.Applicative.pure OperationBody'ALLOW_TRUST + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 8 + = Control.Applicative.pure OperationBody'ACCOUNT_MERGE + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 9 = Control.Applicative.pure OperationBody'INFLATION + xdrGetUnionArm 10 + = Control.Applicative.pure OperationBody'MANAGE_DATA + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 11 + = Control.Applicative.pure OperationBody'BUMP_SEQUENCE + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 12 + = Control.Applicative.pure OperationBody'MANAGE_BUY_OFFER + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 13 + = Control.Applicative.pure OperationBody'PATH_PAYMENT_STRICT_SEND + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 14 + = Control.Applicative.pure OperationBody'CREATE_CLAIMABLE_BALANCE + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 15 + = Control.Applicative.pure OperationBody'CLAIM_CLAIMABLE_BALANCE + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 16 + = Control.Applicative.pure + OperationBody'BEGIN_SPONSORING_FUTURE_RESERVES + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 17 + = Control.Applicative.pure + OperationBody'END_SPONSORING_FUTURE_RESERVES + xdrGetUnionArm 18 + = Control.Applicative.pure OperationBody'REVOKE_SPONSORSHIP + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 19 + = Control.Applicative.pure OperationBody'CLAWBACK + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 20 + = Control.Applicative.pure OperationBody'CLAWBACK_CLAIMABLE_BALANCE + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 21 + = Control.Applicative.pure OperationBody'SET_TRUST_LINE_FLAGS + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 22 + = Control.Applicative.pure OperationBody'LIQUIDITY_POOL_DEPOSIT + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 23 + = Control.Applicative.pure OperationBody'LIQUIDITY_POOL_WITHDRAW + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = Prelude.fail "invalid OperationBody discriminant" + +data Operation = Operation{operation'sourceAccount :: + !(XDR.Optional AccountID), + operation'body :: !OperationBody} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR Operation where + xdrType _ = "Operation" + xdrPut _x + = XDR.xdrPut (operation'sourceAccount _x) Control.Applicative.*> + XDR.xdrPut (operation'body _x) + xdrGet + = Control.Applicative.pure Operation Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data MemoType = MEMO_NONE + | MEMO_TEXT + | MEMO_ID + | MEMO_HASH + | MEMO_RETURN + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR MemoType where + xdrType _ = "MemoType" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum MemoType where + xdrFromEnum MEMO_NONE = 0 + xdrFromEnum MEMO_TEXT = 1 + xdrFromEnum MEMO_ID = 2 + xdrFromEnum MEMO_HASH = 3 + xdrFromEnum MEMO_RETURN = 4 + xdrToEnum 0 = Prelude.return MEMO_NONE + xdrToEnum 1 = Prelude.return MEMO_TEXT + xdrToEnum 2 = Prelude.return MEMO_ID + xdrToEnum 3 = Prelude.return MEMO_HASH + xdrToEnum 4 = Prelude.return MEMO_RETURN + xdrToEnum _ = Prelude.fail "invalid MemoType" + +data Memo = Memo'MEMO_NONE{} + | Memo'MEMO_TEXT{memo'text :: !(XDR.String 28)} + | Memo'MEMO_ID{memo'id :: !Uint64} + | Memo'MEMO_HASH{memo'hash :: !Hash} + | Memo'MEMO_RETURN{memo'retHash :: !Hash} + deriving (Prelude.Eq, Prelude.Show) + +memo'type :: Memo -> MemoType +memo'type = XDR.xdrDiscriminant + +instance XDR.XDR Memo where + xdrType _ = "Memo" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion Memo where + type XDRDiscriminant Memo = MemoType + xdrSplitUnion _x@Memo'MEMO_NONE{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion _x@Memo'MEMO_TEXT{} = (1, XDR.xdrPut (memo'text _x)) + xdrSplitUnion _x@Memo'MEMO_ID{} = (2, XDR.xdrPut (memo'id _x)) + xdrSplitUnion _x@Memo'MEMO_HASH{} = (3, XDR.xdrPut (memo'hash _x)) + xdrSplitUnion _x@Memo'MEMO_RETURN{} + = (4, XDR.xdrPut (memo'retHash _x)) + xdrGetUnionArm 0 = Control.Applicative.pure Memo'MEMO_NONE + xdrGetUnionArm 1 + = Control.Applicative.pure Memo'MEMO_TEXT Control.Applicative.<*> + XDR.xdrGet + xdrGetUnionArm 2 + = Control.Applicative.pure Memo'MEMO_ID Control.Applicative.<*> + XDR.xdrGet + xdrGetUnionArm 3 + = Control.Applicative.pure Memo'MEMO_HASH Control.Applicative.<*> + XDR.xdrGet + xdrGetUnionArm 4 + = Control.Applicative.pure Memo'MEMO_RETURN Control.Applicative.<*> + XDR.xdrGet + xdrGetUnionArm _c = Prelude.fail "invalid Memo discriminant" + +data TimeBounds = TimeBounds{timeBounds'minTime :: !TimePoint, + timeBounds'maxTime :: !TimePoint} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR TimeBounds where + xdrType _ = "TimeBounds" + xdrPut _x + = XDR.xdrPut (timeBounds'minTime _x) Control.Applicative.*> + XDR.xdrPut (timeBounds'maxTime _x) + xdrGet + = Control.Applicative.pure TimeBounds Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data LedgerBounds = LedgerBounds{ledgerBounds'minLedger :: !Uint32, + ledgerBounds'maxLedger :: !Uint32} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR LedgerBounds where + xdrType _ = "LedgerBounds" + xdrPut _x + = XDR.xdrPut (ledgerBounds'minLedger _x) Control.Applicative.*> + XDR.xdrPut (ledgerBounds'maxLedger _x) + xdrGet + = Control.Applicative.pure LedgerBounds Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data PreconditionsV2 = PreconditionsV2{preconditionsV2'timeBounds + :: !(XDR.Optional TimeBounds), + preconditionsV2'ledgerBounds :: !(XDR.Optional LedgerBounds), + preconditionsV2'minSeqNum :: !(XDR.Optional SequenceNumber), + preconditionsV2'minSeqAge :: !Duration, + preconditionsV2'minSeqLedgerGap :: !Uint32, + preconditionsV2'extraSigners :: !(XDR.Array 2 SignerKey)} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR PreconditionsV2 where + xdrType _ = "PreconditionsV2" + xdrPut _x + = XDR.xdrPut (preconditionsV2'timeBounds _x) Control.Applicative.*> + XDR.xdrPut (preconditionsV2'ledgerBounds _x) + Control.Applicative.*> XDR.xdrPut (preconditionsV2'minSeqNum _x) + Control.Applicative.*> XDR.xdrPut (preconditionsV2'minSeqAge _x) + Control.Applicative.*> + XDR.xdrPut (preconditionsV2'minSeqLedgerGap _x) + Control.Applicative.*> XDR.xdrPut (preconditionsV2'extraSigners _x) + xdrGet + = Control.Applicative.pure PreconditionsV2 Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data PreconditionType = PRECOND_NONE + | PRECOND_TIME + | PRECOND_V2 + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR PreconditionType where + xdrType _ = "PreconditionType" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum PreconditionType where + xdrFromEnum PRECOND_NONE = 0 + xdrFromEnum PRECOND_TIME = 1 + xdrFromEnum PRECOND_V2 = 2 + xdrToEnum 0 = Prelude.return PRECOND_NONE + xdrToEnum 1 = Prelude.return PRECOND_TIME + xdrToEnum 2 = Prelude.return PRECOND_V2 + xdrToEnum _ = Prelude.fail "invalid PreconditionType" + +data Preconditions = Preconditions'PRECOND_NONE{} + | Preconditions'PRECOND_TIME{preconditions'timeBounds :: + !TimeBounds} + | Preconditions'PRECOND_V2{preconditions'v2 :: !PreconditionsV2} + deriving (Prelude.Eq, Prelude.Show) + +preconditions'type :: Preconditions -> PreconditionType +preconditions'type = XDR.xdrDiscriminant + +instance XDR.XDR Preconditions where + xdrType _ = "Preconditions" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion Preconditions where + type XDRDiscriminant Preconditions = PreconditionType + xdrSplitUnion _x@Preconditions'PRECOND_NONE{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion _x@Preconditions'PRECOND_TIME{} + = (1, XDR.xdrPut (preconditions'timeBounds _x)) + xdrSplitUnion _x@Preconditions'PRECOND_V2{} + = (2, XDR.xdrPut (preconditions'v2 _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure Preconditions'PRECOND_NONE + xdrGetUnionArm 1 + = Control.Applicative.pure Preconditions'PRECOND_TIME + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 2 + = Control.Applicative.pure Preconditions'PRECOND_V2 + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = Prelude.fail "invalid Preconditions discriminant" + +mAX_OPS_PER_TX :: Prelude.Integral a => a +mAX_OPS_PER_TX = 100 + +data TransactionV0 = TransactionV0{transactionV0'sourceAccountEd25519 + :: !Uint256, + transactionV0'fee :: !Uint32, + transactionV0'seqNum :: !SequenceNumber, + transactionV0'timeBounds :: !(XDR.Optional TimeBounds), + transactionV0'memo :: !Memo, + transactionV0'operations :: !(XDR.Array 100 Operation), + transactionV0'v :: !XDR.Int} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR TransactionV0 where + xdrType _ = "TransactionV0" + xdrPut _x + = XDR.xdrPut (transactionV0'sourceAccountEd25519 _x) + Control.Applicative.*> XDR.xdrPut (transactionV0'fee _x) + Control.Applicative.*> XDR.xdrPut (transactionV0'seqNum _x) + Control.Applicative.*> XDR.xdrPut (transactionV0'timeBounds _x) + Control.Applicative.*> XDR.xdrPut (transactionV0'memo _x) + Control.Applicative.*> XDR.xdrPut (transactionV0'operations _x) + Control.Applicative.*> XDR.xdrPut (transactionV0'v _x) + xdrGet + = Control.Applicative.pure TransactionV0 Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data TransactionV0Envelope = TransactionV0Envelope{transactionV0Envelope'tx + :: !TransactionV0, + transactionV0Envelope'signatures :: + !(XDR.Array 20 DecoratedSignature)} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR TransactionV0Envelope where + xdrType _ = "TransactionV0Envelope" + xdrPut _x + = XDR.xdrPut (transactionV0Envelope'tx _x) Control.Applicative.*> + XDR.xdrPut (transactionV0Envelope'signatures _x) + xdrGet + = Control.Applicative.pure TransactionV0Envelope + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data Transaction = Transaction{transaction'sourceAccount :: + !MuxedAccount, + transaction'fee :: !Uint32, transaction'seqNum :: !SequenceNumber, + transaction'cond :: !Preconditions, transaction'memo :: !Memo, + transaction'operations :: !(XDR.Array 100 Operation), + transaction'v :: !XDR.Int} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR Transaction where + xdrType _ = "Transaction" + xdrPut _x + = XDR.xdrPut (transaction'sourceAccount _x) Control.Applicative.*> + XDR.xdrPut (transaction'fee _x) + Control.Applicative.*> XDR.xdrPut (transaction'seqNum _x) + Control.Applicative.*> XDR.xdrPut (transaction'cond _x) + Control.Applicative.*> XDR.xdrPut (transaction'memo _x) + Control.Applicative.*> XDR.xdrPut (transaction'operations _x) + Control.Applicative.*> XDR.xdrPut (transaction'v _x) + xdrGet + = Control.Applicative.pure Transaction Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data TransactionV1Envelope = TransactionV1Envelope{transactionV1Envelope'tx + :: !Transaction, + transactionV1Envelope'signatures :: + !(XDR.Array 20 DecoratedSignature)} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR TransactionV1Envelope where + xdrType _ = "TransactionV1Envelope" + xdrPut _x + = XDR.xdrPut (transactionV1Envelope'tx _x) Control.Applicative.*> + XDR.xdrPut (transactionV1Envelope'signatures _x) + xdrGet + = Control.Applicative.pure TransactionV1Envelope + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data FeeBumpTransaction_innerTx = FeeBumpTransaction_innerTx'ENVELOPE_TYPE_TX{feeBumpTransaction_innerTx'v1 + :: + !TransactionV1Envelope} + deriving (Prelude.Eq, Prelude.Show) + +feeBumpTransaction_innerTx'type :: + FeeBumpTransaction_innerTx -> EnvelopeType +feeBumpTransaction_innerTx'type = XDR.xdrDiscriminant + +instance XDR.XDR FeeBumpTransaction_innerTx where + xdrType _ = "FeeBumpTransaction_innerTx" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion FeeBumpTransaction_innerTx where + type XDRDiscriminant FeeBumpTransaction_innerTx = EnvelopeType + xdrSplitUnion _x@FeeBumpTransaction_innerTx'ENVELOPE_TYPE_TX{} + = (2, XDR.xdrPut (feeBumpTransaction_innerTx'v1 _x)) + xdrGetUnionArm 2 + = Control.Applicative.pure + FeeBumpTransaction_innerTx'ENVELOPE_TYPE_TX + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = Prelude.fail "invalid FeeBumpTransaction_innerTx discriminant" + +data FeeBumpTransaction = FeeBumpTransaction{feeBumpTransaction'feeSource + :: !MuxedAccount, + feeBumpTransaction'fee :: !Int64, + feeBumpTransaction'innerTx :: + !FeeBumpTransaction_innerTx, + feeBumpTransaction'v :: !XDR.Int} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR FeeBumpTransaction where + xdrType _ = "FeeBumpTransaction" + xdrPut _x + = XDR.xdrPut (feeBumpTransaction'feeSource _x) + Control.Applicative.*> XDR.xdrPut (feeBumpTransaction'fee _x) + Control.Applicative.*> XDR.xdrPut (feeBumpTransaction'innerTx _x) + Control.Applicative.*> XDR.xdrPut (feeBumpTransaction'v _x) + xdrGet + = Control.Applicative.pure FeeBumpTransaction + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data FeeBumpTransactionEnvelope = FeeBumpTransactionEnvelope{feeBumpTransactionEnvelope'tx + :: !FeeBumpTransaction, + feeBumpTransactionEnvelope'signatures + :: !(XDR.Array 20 DecoratedSignature)} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR FeeBumpTransactionEnvelope where + xdrType _ = "FeeBumpTransactionEnvelope" + xdrPut _x + = XDR.xdrPut (feeBumpTransactionEnvelope'tx _x) + Control.Applicative.*> + XDR.xdrPut (feeBumpTransactionEnvelope'signatures _x) + xdrGet + = Control.Applicative.pure FeeBumpTransactionEnvelope + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data TransactionEnvelope = TransactionEnvelope'ENVELOPE_TYPE_TX_V0{transactionEnvelope'v0 + :: !TransactionV0Envelope} + | TransactionEnvelope'ENVELOPE_TYPE_TX{transactionEnvelope'v1 :: + !TransactionV1Envelope} + | TransactionEnvelope'ENVELOPE_TYPE_TX_FEE_BUMP{transactionEnvelope'feeBump + :: + !FeeBumpTransactionEnvelope} + deriving (Prelude.Eq, Prelude.Show) + +transactionEnvelope'type :: TransactionEnvelope -> EnvelopeType +transactionEnvelope'type = XDR.xdrDiscriminant + +instance XDR.XDR TransactionEnvelope where + xdrType _ = "TransactionEnvelope" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion TransactionEnvelope where + type XDRDiscriminant TransactionEnvelope = EnvelopeType + xdrSplitUnion _x@TransactionEnvelope'ENVELOPE_TYPE_TX_V0{} + = (0, XDR.xdrPut (transactionEnvelope'v0 _x)) + xdrSplitUnion _x@TransactionEnvelope'ENVELOPE_TYPE_TX{} + = (2, XDR.xdrPut (transactionEnvelope'v1 _x)) + xdrSplitUnion _x@TransactionEnvelope'ENVELOPE_TYPE_TX_FEE_BUMP{} + = (5, XDR.xdrPut (transactionEnvelope'feeBump _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure TransactionEnvelope'ENVELOPE_TYPE_TX_V0 + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 2 + = Control.Applicative.pure TransactionEnvelope'ENVELOPE_TYPE_TX + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 5 + = Control.Applicative.pure + TransactionEnvelope'ENVELOPE_TYPE_TX_FEE_BUMP + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm c + = Prelude.fail Prelude.$ "invalid TransactionEnvelope discriminant: " Prelude.++ Prelude.show c + +data TransactionSignaturePayload_taggedTransaction = TransactionSignaturePayload_taggedTransaction'ENVELOPE_TYPE_TX{transactionSignaturePayload_taggedTransaction'tx + :: + !Transaction} + | TransactionSignaturePayload_taggedTransaction'ENVELOPE_TYPE_TX_FEE_BUMP{transactionSignaturePayload_taggedTransaction'feeBump + :: + !FeeBumpTransaction} + deriving (Prelude.Eq, Prelude.Show) + +transactionSignaturePayload_taggedTransaction'type :: + TransactionSignaturePayload_taggedTransaction -> + EnvelopeType +transactionSignaturePayload_taggedTransaction'type + = XDR.xdrDiscriminant + +instance XDR.XDR TransactionSignaturePayload_taggedTransaction + where + xdrType _ = "TransactionSignaturePayload_taggedTransaction" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion TransactionSignaturePayload_taggedTransaction + where + type XDRDiscriminant TransactionSignaturePayload_taggedTransaction + = EnvelopeType + xdrSplitUnion + _x@TransactionSignaturePayload_taggedTransaction'ENVELOPE_TYPE_TX{} + = (2, + XDR.xdrPut (transactionSignaturePayload_taggedTransaction'tx _x)) + xdrSplitUnion + _x@TransactionSignaturePayload_taggedTransaction'ENVELOPE_TYPE_TX_FEE_BUMP{} + = (5, + XDR.xdrPut + (transactionSignaturePayload_taggedTransaction'feeBump _x)) + xdrGetUnionArm 2 + = Control.Applicative.pure + TransactionSignaturePayload_taggedTransaction'ENVELOPE_TYPE_TX + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 5 + = Control.Applicative.pure + TransactionSignaturePayload_taggedTransaction'ENVELOPE_TYPE_TX_FEE_BUMP + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = Prelude.fail + "invalid TransactionSignaturePayload_taggedTransaction discriminant" + +data TransactionSignaturePayload = TransactionSignaturePayload{transactionSignaturePayload'networkId + :: !Hash, + transactionSignaturePayload'taggedTransaction + :: + !TransactionSignaturePayload_taggedTransaction} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR TransactionSignaturePayload where + xdrType _ = "TransactionSignaturePayload" + xdrPut _x + = XDR.xdrPut (transactionSignaturePayload'networkId _x) + Control.Applicative.*> + XDR.xdrPut (transactionSignaturePayload'taggedTransaction _x) + xdrGet + = Control.Applicative.pure TransactionSignaturePayload + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data ClaimAtomType = CLAIM_ATOM_TYPE_V0 + | CLAIM_ATOM_TYPE_ORDER_BOOK + | CLAIM_ATOM_TYPE_LIQUIDITY_POOL + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR ClaimAtomType where + xdrType _ = "ClaimAtomType" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum ClaimAtomType where + xdrFromEnum CLAIM_ATOM_TYPE_V0 = 0 + xdrFromEnum CLAIM_ATOM_TYPE_ORDER_BOOK = 1 + xdrFromEnum CLAIM_ATOM_TYPE_LIQUIDITY_POOL = 2 + xdrToEnum 0 = Prelude.return CLAIM_ATOM_TYPE_V0 + xdrToEnum 1 = Prelude.return CLAIM_ATOM_TYPE_ORDER_BOOK + xdrToEnum 2 = Prelude.return CLAIM_ATOM_TYPE_LIQUIDITY_POOL + xdrToEnum _ = Prelude.fail "invalid ClaimAtomType" + +data ClaimOfferAtomV0 = ClaimOfferAtomV0{claimOfferAtomV0'sellerEd25519 + :: !Uint256, + claimOfferAtomV0'offerID :: !Int64, + claimOfferAtomV0'assetSold :: !Asset, + claimOfferAtomV0'amountSold :: !Int64, + claimOfferAtomV0'assetBought :: !Asset, + claimOfferAtomV0'amountBought :: !Int64} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR ClaimOfferAtomV0 where + xdrType _ = "ClaimOfferAtomV0" + xdrPut _x + = XDR.xdrPut (claimOfferAtomV0'sellerEd25519 _x) + Control.Applicative.*> XDR.xdrPut (claimOfferAtomV0'offerID _x) + Control.Applicative.*> XDR.xdrPut (claimOfferAtomV0'assetSold _x) + Control.Applicative.*> XDR.xdrPut (claimOfferAtomV0'amountSold _x) + Control.Applicative.*> XDR.xdrPut (claimOfferAtomV0'assetBought _x) + Control.Applicative.*> + XDR.xdrPut (claimOfferAtomV0'amountBought _x) + xdrGet + = Control.Applicative.pure ClaimOfferAtomV0 Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data ClaimOfferAtom = ClaimOfferAtom{claimOfferAtom'sellerID :: + !AccountID, + claimOfferAtom'offerID :: !Int64, + claimOfferAtom'assetSold :: !Asset, + claimOfferAtom'amountSold :: !Int64, + claimOfferAtom'assetBought :: !Asset, + claimOfferAtom'amountBought :: !Int64} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR ClaimOfferAtom where + xdrType _ = "ClaimOfferAtom" + xdrPut _x + = XDR.xdrPut (claimOfferAtom'sellerID _x) Control.Applicative.*> + XDR.xdrPut (claimOfferAtom'offerID _x) + Control.Applicative.*> XDR.xdrPut (claimOfferAtom'assetSold _x) + Control.Applicative.*> XDR.xdrPut (claimOfferAtom'amountSold _x) + Control.Applicative.*> XDR.xdrPut (claimOfferAtom'assetBought _x) + Control.Applicative.*> XDR.xdrPut (claimOfferAtom'amountBought _x) + xdrGet + = Control.Applicative.pure ClaimOfferAtom Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data ClaimLiquidityAtom = ClaimLiquidityAtom{claimLiquidityAtom'liquidityPoolID + :: !PoolID, + claimLiquidityAtom'assetSold :: !Asset, + claimLiquidityAtom'amountSold :: !Int64, + claimLiquidityAtom'assetBought :: !Asset, + claimLiquidityAtom'amountBought :: !Int64} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR ClaimLiquidityAtom where + xdrType _ = "ClaimLiquidityAtom" + xdrPut _x + = XDR.xdrPut (claimLiquidityAtom'liquidityPoolID _x) + Control.Applicative.*> XDR.xdrPut (claimLiquidityAtom'assetSold _x) + Control.Applicative.*> + XDR.xdrPut (claimLiquidityAtom'amountSold _x) + Control.Applicative.*> + XDR.xdrPut (claimLiquidityAtom'assetBought _x) + Control.Applicative.*> + XDR.xdrPut (claimLiquidityAtom'amountBought _x) + xdrGet + = Control.Applicative.pure ClaimLiquidityAtom + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data ClaimAtom = ClaimAtom'CLAIM_ATOM_TYPE_V0{claimAtom'v0 :: + !ClaimOfferAtomV0} + | ClaimAtom'CLAIM_ATOM_TYPE_ORDER_BOOK{claimAtom'orderBook :: + !ClaimOfferAtom} + | ClaimAtom'CLAIM_ATOM_TYPE_LIQUIDITY_POOL{claimAtom'liquidityPool + :: !ClaimLiquidityAtom} + deriving (Prelude.Eq, Prelude.Show) + +claimAtom'type :: ClaimAtom -> ClaimAtomType +claimAtom'type = XDR.xdrDiscriminant + +instance XDR.XDR ClaimAtom where + xdrType _ = "ClaimAtom" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion ClaimAtom where + type XDRDiscriminant ClaimAtom = ClaimAtomType + xdrSplitUnion _x@ClaimAtom'CLAIM_ATOM_TYPE_V0{} + = (0, XDR.xdrPut (claimAtom'v0 _x)) + xdrSplitUnion _x@ClaimAtom'CLAIM_ATOM_TYPE_ORDER_BOOK{} + = (1, XDR.xdrPut (claimAtom'orderBook _x)) + xdrSplitUnion _x@ClaimAtom'CLAIM_ATOM_TYPE_LIQUIDITY_POOL{} + = (2, XDR.xdrPut (claimAtom'liquidityPool _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure ClaimAtom'CLAIM_ATOM_TYPE_V0 + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 1 + = Control.Applicative.pure ClaimAtom'CLAIM_ATOM_TYPE_ORDER_BOOK + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 2 + = Control.Applicative.pure ClaimAtom'CLAIM_ATOM_TYPE_LIQUIDITY_POOL + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c = Prelude.fail "invalid ClaimAtom discriminant" + +data CreateAccountResultCode = CREATE_ACCOUNT_SUCCESS + | CREATE_ACCOUNT_MALFORMED + | CREATE_ACCOUNT_UNDERFUNDED + | CREATE_ACCOUNT_LOW_RESERVE + | CREATE_ACCOUNT_ALREADY_EXIST + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR CreateAccountResultCode where + xdrType _ = "CreateAccountResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum CreateAccountResultCode where + xdrFromEnum CREATE_ACCOUNT_SUCCESS = 0 + xdrFromEnum CREATE_ACCOUNT_MALFORMED = -1 + xdrFromEnum CREATE_ACCOUNT_UNDERFUNDED = -2 + xdrFromEnum CREATE_ACCOUNT_LOW_RESERVE = -3 + xdrFromEnum CREATE_ACCOUNT_ALREADY_EXIST = -4 + xdrToEnum 0 = Prelude.return CREATE_ACCOUNT_SUCCESS + xdrToEnum (-1) = Prelude.return CREATE_ACCOUNT_MALFORMED + xdrToEnum (-2) = Prelude.return CREATE_ACCOUNT_UNDERFUNDED + xdrToEnum (-3) = Prelude.return CREATE_ACCOUNT_LOW_RESERVE + xdrToEnum (-4) = Prelude.return CREATE_ACCOUNT_ALREADY_EXIST + xdrToEnum _ = Prelude.fail "invalid CreateAccountResultCode" + +data CreateAccountResult = CreateAccountResult'CREATE_ACCOUNT_SUCCESS{} + | CreateAccountResult'CREATE_ACCOUNT_MALFORMED{} + | CreateAccountResult'CREATE_ACCOUNT_UNDERFUNDED{} + | CreateAccountResult'CREATE_ACCOUNT_LOW_RESERVE{} + | CreateAccountResult'CREATE_ACCOUNT_ALREADY_EXIST{} + deriving (Prelude.Eq, Prelude.Show) + +createAccountResult'code :: + CreateAccountResult -> CreateAccountResultCode +createAccountResult'code = XDR.xdrDiscriminant + +instance XDR.XDR CreateAccountResult where + xdrType _ = "CreateAccountResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion CreateAccountResult where + type XDRDiscriminant CreateAccountResult = CreateAccountResultCode + xdrSplitUnion _x@CreateAccountResult'CREATE_ACCOUNT_SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion _x@CreateAccountResult'CREATE_ACCOUNT_MALFORMED{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion _x@CreateAccountResult'CREATE_ACCOUNT_UNDERFUNDED{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion _x@CreateAccountResult'CREATE_ACCOUNT_LOW_RESERVE{} + = (-3, Control.Applicative.pure ()) + xdrSplitUnion _x@CreateAccountResult'CREATE_ACCOUNT_ALREADY_EXIST{} + = (-4, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure + CreateAccountResult'CREATE_ACCOUNT_SUCCESS + xdrGetUnionArm (-1) + = Control.Applicative.pure + CreateAccountResult'CREATE_ACCOUNT_MALFORMED + xdrGetUnionArm (-2) + = Control.Applicative.pure + CreateAccountResult'CREATE_ACCOUNT_UNDERFUNDED + xdrGetUnionArm (-3) + = Control.Applicative.pure + CreateAccountResult'CREATE_ACCOUNT_LOW_RESERVE + xdrGetUnionArm (-4) + = Control.Applicative.pure + CreateAccountResult'CREATE_ACCOUNT_ALREADY_EXIST + xdrGetUnionArm _c + = Prelude.fail "invalid CreateAccountResult discriminant" + +data PaymentResultCode = PAYMENT_SUCCESS + | PAYMENT_MALFORMED + | PAYMENT_UNDERFUNDED + | PAYMENT_SRC_NO_TRUST + | PAYMENT_SRC_NOT_AUTHORIZED + | PAYMENT_NO_DESTINATION + | PAYMENT_NO_TRUST + | PAYMENT_NOT_AUTHORIZED + | PAYMENT_LINE_FULL + | PAYMENT_NO_ISSUER + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR PaymentResultCode where + xdrType _ = "PaymentResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum PaymentResultCode where + xdrFromEnum PAYMENT_SUCCESS = 0 + xdrFromEnum PAYMENT_MALFORMED = -1 + xdrFromEnum PAYMENT_UNDERFUNDED = -2 + xdrFromEnum PAYMENT_SRC_NO_TRUST = -3 + xdrFromEnum PAYMENT_SRC_NOT_AUTHORIZED = -4 + xdrFromEnum PAYMENT_NO_DESTINATION = -5 + xdrFromEnum PAYMENT_NO_TRUST = -6 + xdrFromEnum PAYMENT_NOT_AUTHORIZED = -7 + xdrFromEnum PAYMENT_LINE_FULL = -8 + xdrFromEnum PAYMENT_NO_ISSUER = -9 + xdrToEnum 0 = Prelude.return PAYMENT_SUCCESS + xdrToEnum (-1) = Prelude.return PAYMENT_MALFORMED + xdrToEnum (-2) = Prelude.return PAYMENT_UNDERFUNDED + xdrToEnum (-3) = Prelude.return PAYMENT_SRC_NO_TRUST + xdrToEnum (-4) = Prelude.return PAYMENT_SRC_NOT_AUTHORIZED + xdrToEnum (-5) = Prelude.return PAYMENT_NO_DESTINATION + xdrToEnum (-6) = Prelude.return PAYMENT_NO_TRUST + xdrToEnum (-7) = Prelude.return PAYMENT_NOT_AUTHORIZED + xdrToEnum (-8) = Prelude.return PAYMENT_LINE_FULL + xdrToEnum (-9) = Prelude.return PAYMENT_NO_ISSUER + xdrToEnum _ = Prelude.fail "invalid PaymentResultCode" + +data PaymentResult = PaymentResult'PAYMENT_SUCCESS{} + | PaymentResult'PAYMENT_MALFORMED{} + | PaymentResult'PAYMENT_UNDERFUNDED{} + | PaymentResult'PAYMENT_SRC_NO_TRUST{} + | PaymentResult'PAYMENT_SRC_NOT_AUTHORIZED{} + | PaymentResult'PAYMENT_NO_DESTINATION{} + | PaymentResult'PAYMENT_NO_TRUST{} + | PaymentResult'PAYMENT_NOT_AUTHORIZED{} + | PaymentResult'PAYMENT_LINE_FULL{} + | PaymentResult'PAYMENT_NO_ISSUER{} + deriving (Prelude.Eq, Prelude.Show) + +paymentResult'code :: PaymentResult -> PaymentResultCode +paymentResult'code = XDR.xdrDiscriminant + +instance XDR.XDR PaymentResult where + xdrType _ = "PaymentResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion PaymentResult where + type XDRDiscriminant PaymentResult = PaymentResultCode + xdrSplitUnion _x@PaymentResult'PAYMENT_SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion _x@PaymentResult'PAYMENT_MALFORMED{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion _x@PaymentResult'PAYMENT_UNDERFUNDED{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion _x@PaymentResult'PAYMENT_SRC_NO_TRUST{} + = (-3, Control.Applicative.pure ()) + xdrSplitUnion _x@PaymentResult'PAYMENT_SRC_NOT_AUTHORIZED{} + = (-4, Control.Applicative.pure ()) + xdrSplitUnion _x@PaymentResult'PAYMENT_NO_DESTINATION{} + = (-5, Control.Applicative.pure ()) + xdrSplitUnion _x@PaymentResult'PAYMENT_NO_TRUST{} + = (-6, Control.Applicative.pure ()) + xdrSplitUnion _x@PaymentResult'PAYMENT_NOT_AUTHORIZED{} + = (-7, Control.Applicative.pure ()) + xdrSplitUnion _x@PaymentResult'PAYMENT_LINE_FULL{} + = (-8, Control.Applicative.pure ()) + xdrSplitUnion _x@PaymentResult'PAYMENT_NO_ISSUER{} + = (-9, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure PaymentResult'PAYMENT_SUCCESS + xdrGetUnionArm (-1) + = Control.Applicative.pure PaymentResult'PAYMENT_MALFORMED + xdrGetUnionArm (-2) + = Control.Applicative.pure PaymentResult'PAYMENT_UNDERFUNDED + xdrGetUnionArm (-3) + = Control.Applicative.pure PaymentResult'PAYMENT_SRC_NO_TRUST + xdrGetUnionArm (-4) + = Control.Applicative.pure PaymentResult'PAYMENT_SRC_NOT_AUTHORIZED + xdrGetUnionArm (-5) + = Control.Applicative.pure PaymentResult'PAYMENT_NO_DESTINATION + xdrGetUnionArm (-6) + = Control.Applicative.pure PaymentResult'PAYMENT_NO_TRUST + xdrGetUnionArm (-7) + = Control.Applicative.pure PaymentResult'PAYMENT_NOT_AUTHORIZED + xdrGetUnionArm (-8) + = Control.Applicative.pure PaymentResult'PAYMENT_LINE_FULL + xdrGetUnionArm (-9) + = Control.Applicative.pure PaymentResult'PAYMENT_NO_ISSUER + xdrGetUnionArm _c + = Prelude.fail "invalid PaymentResult discriminant" + +data PathPaymentStrictReceiveResultCode = PATH_PAYMENT_STRICT_RECEIVE_SUCCESS + | PATH_PAYMENT_STRICT_RECEIVE_MALFORMED + | PATH_PAYMENT_STRICT_RECEIVE_UNDERFUNDED + | PATH_PAYMENT_STRICT_RECEIVE_SRC_NO_TRUST + | PATH_PAYMENT_STRICT_RECEIVE_SRC_NOT_AUTHORIZED + | PATH_PAYMENT_STRICT_RECEIVE_NO_DESTINATION + | PATH_PAYMENT_STRICT_RECEIVE_NO_TRUST + | PATH_PAYMENT_STRICT_RECEIVE_NOT_AUTHORIZED + | PATH_PAYMENT_STRICT_RECEIVE_LINE_FULL + | PATH_PAYMENT_STRICT_RECEIVE_NO_ISSUER + | PATH_PAYMENT_STRICT_RECEIVE_TOO_FEW_OFFERS + | PATH_PAYMENT_STRICT_RECEIVE_OFFER_CROSS_SELF + | PATH_PAYMENT_STRICT_RECEIVE_OVER_SENDMAX + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, + Prelude.Bounded, Prelude.Show) + +instance XDR.XDR PathPaymentStrictReceiveResultCode where + xdrType _ = "PathPaymentStrictReceiveResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum PathPaymentStrictReceiveResultCode where + xdrFromEnum PATH_PAYMENT_STRICT_RECEIVE_SUCCESS = 0 + xdrFromEnum PATH_PAYMENT_STRICT_RECEIVE_MALFORMED = -1 + xdrFromEnum PATH_PAYMENT_STRICT_RECEIVE_UNDERFUNDED = -2 + xdrFromEnum PATH_PAYMENT_STRICT_RECEIVE_SRC_NO_TRUST = -3 + xdrFromEnum PATH_PAYMENT_STRICT_RECEIVE_SRC_NOT_AUTHORIZED = -4 + xdrFromEnum PATH_PAYMENT_STRICT_RECEIVE_NO_DESTINATION = -5 + xdrFromEnum PATH_PAYMENT_STRICT_RECEIVE_NO_TRUST = -6 + xdrFromEnum PATH_PAYMENT_STRICT_RECEIVE_NOT_AUTHORIZED = -7 + xdrFromEnum PATH_PAYMENT_STRICT_RECEIVE_LINE_FULL = -8 + xdrFromEnum PATH_PAYMENT_STRICT_RECEIVE_NO_ISSUER = -9 + xdrFromEnum PATH_PAYMENT_STRICT_RECEIVE_TOO_FEW_OFFERS = -10 + xdrFromEnum PATH_PAYMENT_STRICT_RECEIVE_OFFER_CROSS_SELF = -11 + xdrFromEnum PATH_PAYMENT_STRICT_RECEIVE_OVER_SENDMAX = -12 + xdrToEnum 0 = Prelude.return PATH_PAYMENT_STRICT_RECEIVE_SUCCESS + xdrToEnum (-1) + = Prelude.return PATH_PAYMENT_STRICT_RECEIVE_MALFORMED + xdrToEnum (-2) + = Prelude.return PATH_PAYMENT_STRICT_RECEIVE_UNDERFUNDED + xdrToEnum (-3) + = Prelude.return PATH_PAYMENT_STRICT_RECEIVE_SRC_NO_TRUST + xdrToEnum (-4) + = Prelude.return PATH_PAYMENT_STRICT_RECEIVE_SRC_NOT_AUTHORIZED + xdrToEnum (-5) + = Prelude.return PATH_PAYMENT_STRICT_RECEIVE_NO_DESTINATION + xdrToEnum (-6) + = Prelude.return PATH_PAYMENT_STRICT_RECEIVE_NO_TRUST + xdrToEnum (-7) + = Prelude.return PATH_PAYMENT_STRICT_RECEIVE_NOT_AUTHORIZED + xdrToEnum (-8) + = Prelude.return PATH_PAYMENT_STRICT_RECEIVE_LINE_FULL + xdrToEnum (-9) + = Prelude.return PATH_PAYMENT_STRICT_RECEIVE_NO_ISSUER + xdrToEnum (-10) + = Prelude.return PATH_PAYMENT_STRICT_RECEIVE_TOO_FEW_OFFERS + xdrToEnum (-11) + = Prelude.return PATH_PAYMENT_STRICT_RECEIVE_OFFER_CROSS_SELF + xdrToEnum (-12) + = Prelude.return PATH_PAYMENT_STRICT_RECEIVE_OVER_SENDMAX + xdrToEnum _ + = Prelude.fail "invalid PathPaymentStrictReceiveResultCode" + +data SimplePaymentResult = SimplePaymentResult{simplePaymentResult'destination + :: !AccountID, + simplePaymentResult'asset :: !Asset, + simplePaymentResult'amount :: !Int64} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR SimplePaymentResult where + xdrType _ = "SimplePaymentResult" + xdrPut _x + = XDR.xdrPut (simplePaymentResult'destination _x) + Control.Applicative.*> XDR.xdrPut (simplePaymentResult'asset _x) + Control.Applicative.*> XDR.xdrPut (simplePaymentResult'amount _x) + xdrGet + = Control.Applicative.pure SimplePaymentResult + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data PathPaymentStrictReceiveResult = PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_SUCCESS{pathPaymentStrictReceiveResult'success'offers + :: + !(XDR.Array + 4294967295 + ClaimAtom), + pathPaymentStrictReceiveResult'success'last + :: + !SimplePaymentResult} + | PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_MALFORMED{} + | PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_UNDERFUNDED{} + | PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_SRC_NO_TRUST{} + | PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_SRC_NOT_AUTHORIZED{} + | PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_NO_DESTINATION{} + | PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_NO_TRUST{} + | PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_NOT_AUTHORIZED{} + | PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_LINE_FULL{} + | PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_NO_ISSUER{pathPaymentStrictReceiveResult'noIssuer + :: + !Asset} + | PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_TOO_FEW_OFFERS{} + | PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_OFFER_CROSS_SELF{} + | PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_OVER_SENDMAX{} + deriving (Prelude.Eq, Prelude.Show) + +pathPaymentStrictReceiveResult'code :: + PathPaymentStrictReceiveResult -> + PathPaymentStrictReceiveResultCode +pathPaymentStrictReceiveResult'code = XDR.xdrDiscriminant + +instance XDR.XDR PathPaymentStrictReceiveResult where + xdrType _ = "PathPaymentStrictReceiveResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion PathPaymentStrictReceiveResult where + type XDRDiscriminant PathPaymentStrictReceiveResult = + PathPaymentStrictReceiveResultCode + xdrSplitUnion + _x@PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_SUCCESS{} + = (0, + XDR.xdrPut (pathPaymentStrictReceiveResult'success'offers _x) + Control.Applicative.*> + XDR.xdrPut (pathPaymentStrictReceiveResult'success'last _x)) + xdrSplitUnion + _x@PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_MALFORMED{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_UNDERFUNDED{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_SRC_NO_TRUST{} + = (-3, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_SRC_NOT_AUTHORIZED{} + = (-4, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_NO_DESTINATION{} + = (-5, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_NO_TRUST{} + = (-6, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_NOT_AUTHORIZED{} + = (-7, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_LINE_FULL{} + = (-8, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_NO_ISSUER{} + = (-9, XDR.xdrPut (pathPaymentStrictReceiveResult'noIssuer _x)) + xdrSplitUnion + _x@PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_TOO_FEW_OFFERS{} + = (-10, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_OFFER_CROSS_SELF{} + = (-11, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_OVER_SENDMAX{} + = (-12, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure + PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_SUCCESS + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm (-1) + = Control.Applicative.pure + PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_MALFORMED + xdrGetUnionArm (-2) + = Control.Applicative.pure + PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_UNDERFUNDED + xdrGetUnionArm (-3) + = Control.Applicative.pure + PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_SRC_NO_TRUST + xdrGetUnionArm (-4) + = Control.Applicative.pure + PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_SRC_NOT_AUTHORIZED + xdrGetUnionArm (-5) + = Control.Applicative.pure + PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_NO_DESTINATION + xdrGetUnionArm (-6) + = Control.Applicative.pure + PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_NO_TRUST + xdrGetUnionArm (-7) + = Control.Applicative.pure + PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_NOT_AUTHORIZED + xdrGetUnionArm (-8) + = Control.Applicative.pure + PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_LINE_FULL + xdrGetUnionArm (-9) + = Control.Applicative.pure + PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_NO_ISSUER + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm (-10) + = Control.Applicative.pure + PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_TOO_FEW_OFFERS + xdrGetUnionArm (-11) + = Control.Applicative.pure + PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_OFFER_CROSS_SELF + xdrGetUnionArm (-12) + = Control.Applicative.pure + PathPaymentStrictReceiveResult'PATH_PAYMENT_STRICT_RECEIVE_OVER_SENDMAX + xdrGetUnionArm _c + = Prelude.fail + "invalid PathPaymentStrictReceiveResult discriminant" + +data PathPaymentStrictSendResultCode = PATH_PAYMENT_STRICT_SEND_SUCCESS + | PATH_PAYMENT_STRICT_SEND_MALFORMED + | PATH_PAYMENT_STRICT_SEND_UNDERFUNDED + | PATH_PAYMENT_STRICT_SEND_SRC_NO_TRUST + | PATH_PAYMENT_STRICT_SEND_SRC_NOT_AUTHORIZED + | PATH_PAYMENT_STRICT_SEND_NO_DESTINATION + | PATH_PAYMENT_STRICT_SEND_NO_TRUST + | PATH_PAYMENT_STRICT_SEND_NOT_AUTHORIZED + | PATH_PAYMENT_STRICT_SEND_LINE_FULL + | PATH_PAYMENT_STRICT_SEND_NO_ISSUER + | PATH_PAYMENT_STRICT_SEND_TOO_FEW_OFFERS + | PATH_PAYMENT_STRICT_SEND_OFFER_CROSS_SELF + | PATH_PAYMENT_STRICT_SEND_UNDER_DESTMIN + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, + Prelude.Bounded, Prelude.Show) + +instance XDR.XDR PathPaymentStrictSendResultCode where + xdrType _ = "PathPaymentStrictSendResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum PathPaymentStrictSendResultCode where + xdrFromEnum PATH_PAYMENT_STRICT_SEND_SUCCESS = 0 + xdrFromEnum PATH_PAYMENT_STRICT_SEND_MALFORMED = -1 + xdrFromEnum PATH_PAYMENT_STRICT_SEND_UNDERFUNDED = -2 + xdrFromEnum PATH_PAYMENT_STRICT_SEND_SRC_NO_TRUST = -3 + xdrFromEnum PATH_PAYMENT_STRICT_SEND_SRC_NOT_AUTHORIZED = -4 + xdrFromEnum PATH_PAYMENT_STRICT_SEND_NO_DESTINATION = -5 + xdrFromEnum PATH_PAYMENT_STRICT_SEND_NO_TRUST = -6 + xdrFromEnum PATH_PAYMENT_STRICT_SEND_NOT_AUTHORIZED = -7 + xdrFromEnum PATH_PAYMENT_STRICT_SEND_LINE_FULL = -8 + xdrFromEnum PATH_PAYMENT_STRICT_SEND_NO_ISSUER = -9 + xdrFromEnum PATH_PAYMENT_STRICT_SEND_TOO_FEW_OFFERS = -10 + xdrFromEnum PATH_PAYMENT_STRICT_SEND_OFFER_CROSS_SELF = -11 + xdrFromEnum PATH_PAYMENT_STRICT_SEND_UNDER_DESTMIN = -12 + xdrToEnum 0 = Prelude.return PATH_PAYMENT_STRICT_SEND_SUCCESS + xdrToEnum (-1) = Prelude.return PATH_PAYMENT_STRICT_SEND_MALFORMED + xdrToEnum (-2) + = Prelude.return PATH_PAYMENT_STRICT_SEND_UNDERFUNDED + xdrToEnum (-3) + = Prelude.return PATH_PAYMENT_STRICT_SEND_SRC_NO_TRUST + xdrToEnum (-4) + = Prelude.return PATH_PAYMENT_STRICT_SEND_SRC_NOT_AUTHORIZED + xdrToEnum (-5) + = Prelude.return PATH_PAYMENT_STRICT_SEND_NO_DESTINATION + xdrToEnum (-6) = Prelude.return PATH_PAYMENT_STRICT_SEND_NO_TRUST + xdrToEnum (-7) + = Prelude.return PATH_PAYMENT_STRICT_SEND_NOT_AUTHORIZED + xdrToEnum (-8) = Prelude.return PATH_PAYMENT_STRICT_SEND_LINE_FULL + xdrToEnum (-9) = Prelude.return PATH_PAYMENT_STRICT_SEND_NO_ISSUER + xdrToEnum (-10) + = Prelude.return PATH_PAYMENT_STRICT_SEND_TOO_FEW_OFFERS + xdrToEnum (-11) + = Prelude.return PATH_PAYMENT_STRICT_SEND_OFFER_CROSS_SELF + xdrToEnum (-12) + = Prelude.return PATH_PAYMENT_STRICT_SEND_UNDER_DESTMIN + xdrToEnum _ + = Prelude.fail "invalid PathPaymentStrictSendResultCode" + +data PathPaymentStrictSendResult = PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_SUCCESS{pathPaymentStrictSendResult'success'offers + :: + !(XDR.Array + 4294967295 + ClaimAtom), + pathPaymentStrictSendResult'success'last + :: + !SimplePaymentResult} + | PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_MALFORMED{} + | PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_UNDERFUNDED{} + | PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_SRC_NO_TRUST{} + | PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_SRC_NOT_AUTHORIZED{} + | PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_NO_DESTINATION{} + | PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_NO_TRUST{} + | PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_NOT_AUTHORIZED{} + | PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_LINE_FULL{} + | PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_NO_ISSUER{pathPaymentStrictSendResult'noIssuer + :: + !Asset} + | PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_TOO_FEW_OFFERS{} + | PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_OFFER_CROSS_SELF{} + | PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_UNDER_DESTMIN{} + deriving (Prelude.Eq, Prelude.Show) + +pathPaymentStrictSendResult'code :: + PathPaymentStrictSendResult -> PathPaymentStrictSendResultCode +pathPaymentStrictSendResult'code = XDR.xdrDiscriminant + +instance XDR.XDR PathPaymentStrictSendResult where + xdrType _ = "PathPaymentStrictSendResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion PathPaymentStrictSendResult where + type XDRDiscriminant PathPaymentStrictSendResult = + PathPaymentStrictSendResultCode + xdrSplitUnion + _x@PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_SUCCESS{} + = (0, + XDR.xdrPut (pathPaymentStrictSendResult'success'offers _x) + Control.Applicative.*> + XDR.xdrPut (pathPaymentStrictSendResult'success'last _x)) + xdrSplitUnion + _x@PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_MALFORMED{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_UNDERFUNDED{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_SRC_NO_TRUST{} + = (-3, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_SRC_NOT_AUTHORIZED{} + = (-4, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_NO_DESTINATION{} + = (-5, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_NO_TRUST{} + = (-6, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_NOT_AUTHORIZED{} + = (-7, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_LINE_FULL{} + = (-8, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_NO_ISSUER{} + = (-9, XDR.xdrPut (pathPaymentStrictSendResult'noIssuer _x)) + xdrSplitUnion + _x@PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_TOO_FEW_OFFERS{} + = (-10, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_OFFER_CROSS_SELF{} + = (-11, Control.Applicative.pure ()) + xdrSplitUnion + _x@PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_UNDER_DESTMIN{} + = (-12, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure + PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_SUCCESS + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm (-1) + = Control.Applicative.pure + PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_MALFORMED + xdrGetUnionArm (-2) + = Control.Applicative.pure + PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_UNDERFUNDED + xdrGetUnionArm (-3) + = Control.Applicative.pure + PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_SRC_NO_TRUST + xdrGetUnionArm (-4) + = Control.Applicative.pure + PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_SRC_NOT_AUTHORIZED + xdrGetUnionArm (-5) + = Control.Applicative.pure + PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_NO_DESTINATION + xdrGetUnionArm (-6) + = Control.Applicative.pure + PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_NO_TRUST + xdrGetUnionArm (-7) + = Control.Applicative.pure + PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_NOT_AUTHORIZED + xdrGetUnionArm (-8) + = Control.Applicative.pure + PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_LINE_FULL + xdrGetUnionArm (-9) + = Control.Applicative.pure + PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_NO_ISSUER + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm (-10) + = Control.Applicative.pure + PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_TOO_FEW_OFFERS + xdrGetUnionArm (-11) + = Control.Applicative.pure + PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_OFFER_CROSS_SELF + xdrGetUnionArm (-12) + = Control.Applicative.pure + PathPaymentStrictSendResult'PATH_PAYMENT_STRICT_SEND_UNDER_DESTMIN + xdrGetUnionArm _c + = Prelude.fail "invalid PathPaymentStrictSendResult discriminant" + +data ManageSellOfferResultCode = MANAGE_SELL_OFFER_SUCCESS + | MANAGE_SELL_OFFER_MALFORMED + | MANAGE_SELL_OFFER_SELL_NO_TRUST + | MANAGE_SELL_OFFER_BUY_NO_TRUST + | MANAGE_SELL_OFFER_SELL_NOT_AUTHORIZED + | MANAGE_SELL_OFFER_BUY_NOT_AUTHORIZED + | MANAGE_SELL_OFFER_LINE_FULL + | MANAGE_SELL_OFFER_UNDERFUNDED + | MANAGE_SELL_OFFER_CROSS_SELF + | MANAGE_SELL_OFFER_SELL_NO_ISSUER + | MANAGE_SELL_OFFER_BUY_NO_ISSUER + | MANAGE_SELL_OFFER_NOT_FOUND + | MANAGE_SELL_OFFER_LOW_RESERVE + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR ManageSellOfferResultCode where + xdrType _ = "ManageSellOfferResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum ManageSellOfferResultCode where + xdrFromEnum MANAGE_SELL_OFFER_SUCCESS = 0 + xdrFromEnum MANAGE_SELL_OFFER_MALFORMED = -1 + xdrFromEnum MANAGE_SELL_OFFER_SELL_NO_TRUST = -2 + xdrFromEnum MANAGE_SELL_OFFER_BUY_NO_TRUST = -3 + xdrFromEnum MANAGE_SELL_OFFER_SELL_NOT_AUTHORIZED = -4 + xdrFromEnum MANAGE_SELL_OFFER_BUY_NOT_AUTHORIZED = -5 + xdrFromEnum MANAGE_SELL_OFFER_LINE_FULL = -6 + xdrFromEnum MANAGE_SELL_OFFER_UNDERFUNDED = -7 + xdrFromEnum MANAGE_SELL_OFFER_CROSS_SELF = -8 + xdrFromEnum MANAGE_SELL_OFFER_SELL_NO_ISSUER = -9 + xdrFromEnum MANAGE_SELL_OFFER_BUY_NO_ISSUER = -10 + xdrFromEnum MANAGE_SELL_OFFER_NOT_FOUND = -11 + xdrFromEnum MANAGE_SELL_OFFER_LOW_RESERVE = -12 + xdrToEnum 0 = Prelude.return MANAGE_SELL_OFFER_SUCCESS + xdrToEnum (-1) = Prelude.return MANAGE_SELL_OFFER_MALFORMED + xdrToEnum (-2) = Prelude.return MANAGE_SELL_OFFER_SELL_NO_TRUST + xdrToEnum (-3) = Prelude.return MANAGE_SELL_OFFER_BUY_NO_TRUST + xdrToEnum (-4) + = Prelude.return MANAGE_SELL_OFFER_SELL_NOT_AUTHORIZED + xdrToEnum (-5) + = Prelude.return MANAGE_SELL_OFFER_BUY_NOT_AUTHORIZED + xdrToEnum (-6) = Prelude.return MANAGE_SELL_OFFER_LINE_FULL + xdrToEnum (-7) = Prelude.return MANAGE_SELL_OFFER_UNDERFUNDED + xdrToEnum (-8) = Prelude.return MANAGE_SELL_OFFER_CROSS_SELF + xdrToEnum (-9) = Prelude.return MANAGE_SELL_OFFER_SELL_NO_ISSUER + xdrToEnum (-10) = Prelude.return MANAGE_SELL_OFFER_BUY_NO_ISSUER + xdrToEnum (-11) = Prelude.return MANAGE_SELL_OFFER_NOT_FOUND + xdrToEnum (-12) = Prelude.return MANAGE_SELL_OFFER_LOW_RESERVE + xdrToEnum _ = Prelude.fail "invalid ManageSellOfferResultCode" + +data ManageOfferEffect = MANAGE_OFFER_CREATED + | MANAGE_OFFER_UPDATED + | MANAGE_OFFER_DELETED + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR ManageOfferEffect where + xdrType _ = "ManageOfferEffect" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum ManageOfferEffect where + xdrFromEnum MANAGE_OFFER_CREATED = 0 + xdrFromEnum MANAGE_OFFER_UPDATED = 1 + xdrFromEnum MANAGE_OFFER_DELETED = 2 + xdrToEnum 0 = Prelude.return MANAGE_OFFER_CREATED + xdrToEnum 1 = Prelude.return MANAGE_OFFER_UPDATED + xdrToEnum 2 = Prelude.return MANAGE_OFFER_DELETED + xdrToEnum _ = Prelude.fail "invalid ManageOfferEffect" + +data ManageOfferSuccesResult_offer = ManageOfferSuccesResult_offer'MANAGE_OFFER_CREATED{manageOfferSuccesResult_offer'offer + :: + !OfferEntry} + | ManageOfferSuccesResult_offer'MANAGE_OFFER_UPDATED{manageOfferSuccesResult_offer'offer + :: + !OfferEntry} + | ManageOfferSuccesResult_offer'MANAGE_OFFER_DELETED{} + deriving (Prelude.Eq, Prelude.Show) + +manageOfferSuccesResult_offer'effect :: + ManageOfferSuccesResult_offer -> ManageOfferEffect +manageOfferSuccesResult_offer'effect = XDR.xdrDiscriminant + +instance XDR.XDR ManageOfferSuccesResult_offer where + xdrType _ = "ManageOfferSuccesResult_offer" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion ManageOfferSuccesResult_offer where + type XDRDiscriminant ManageOfferSuccesResult_offer = + ManageOfferEffect + xdrSplitUnion + _x@ManageOfferSuccesResult_offer'MANAGE_OFFER_CREATED{} + = (0, XDR.xdrPut (manageOfferSuccesResult_offer'offer _x)) + xdrSplitUnion + _x@ManageOfferSuccesResult_offer'MANAGE_OFFER_UPDATED{} + = (1, XDR.xdrPut (manageOfferSuccesResult_offer'offer _x)) + xdrSplitUnion + _x@ManageOfferSuccesResult_offer'MANAGE_OFFER_DELETED{} + = (2, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure + ManageOfferSuccesResult_offer'MANAGE_OFFER_CREATED + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 1 + = Control.Applicative.pure + ManageOfferSuccesResult_offer'MANAGE_OFFER_UPDATED + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 2 + = Control.Applicative.pure + ManageOfferSuccesResult_offer'MANAGE_OFFER_DELETED + xdrGetUnionArm _c + = Prelude.fail "invalid ManageOfferSuccesResult_offer discriminant" + +data ManageOfferSuccessResult = ManageOfferSuccessResult{manageOfferSuccessResult'offersClaimed + :: !(XDR.Array 4294967295 ClaimAtom), + manageOfferSuccessResult'offer :: + !ManageOfferSuccesResult_offer} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR ManageOfferSuccessResult where + xdrType _ = "ManageOfferSuccessResult" + xdrPut _x + = XDR.xdrPut (manageOfferSuccessResult'offersClaimed _x) + Control.Applicative.*> + XDR.xdrPut (manageOfferSuccessResult'offer _x) + xdrGet + = Control.Applicative.pure ManageOfferSuccessResult + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data ManageSellOfferResult = ManageSellOfferResult'MANAGE_SELL_OFFER_SUCCESS{manageSellOfferResult'success + :: + !ManageOfferSuccessResult} + | ManageSellOfferResult'MANAGE_SELL_OFFER_MALFORMED{} + | ManageSellOfferResult'MANAGE_SELL_OFFER_SELL_NO_TRUST{} + | ManageSellOfferResult'MANAGE_SELL_OFFER_BUY_NO_TRUST{} + | ManageSellOfferResult'MANAGE_SELL_OFFER_SELL_NOT_AUTHORIZED{} + | ManageSellOfferResult'MANAGE_SELL_OFFER_BUY_NOT_AUTHORIZED{} + | ManageSellOfferResult'MANAGE_SELL_OFFER_LINE_FULL{} + | ManageSellOfferResult'MANAGE_SELL_OFFER_UNDERFUNDED{} + | ManageSellOfferResult'MANAGE_SELL_OFFER_CROSS_SELF{} + | ManageSellOfferResult'MANAGE_SELL_OFFER_SELL_NO_ISSUER{} + | ManageSellOfferResult'MANAGE_SELL_OFFER_BUY_NO_ISSUER{} + | ManageSellOfferResult'MANAGE_SELL_OFFER_NOT_FOUND{} + | ManageSellOfferResult'MANAGE_SELL_OFFER_LOW_RESERVE{} + deriving (Prelude.Eq, Prelude.Show) + +manageSellOfferResult'code :: + ManageSellOfferResult -> ManageSellOfferResultCode +manageSellOfferResult'code = XDR.xdrDiscriminant + +instance XDR.XDR ManageSellOfferResult where + xdrType _ = "ManageSellOfferResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion ManageSellOfferResult where + type XDRDiscriminant ManageSellOfferResult = + ManageSellOfferResultCode + xdrSplitUnion _x@ManageSellOfferResult'MANAGE_SELL_OFFER_SUCCESS{} + = (0, XDR.xdrPut (manageSellOfferResult'success _x)) + xdrSplitUnion + _x@ManageSellOfferResult'MANAGE_SELL_OFFER_MALFORMED{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageSellOfferResult'MANAGE_SELL_OFFER_SELL_NO_TRUST{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageSellOfferResult'MANAGE_SELL_OFFER_BUY_NO_TRUST{} + = (-3, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageSellOfferResult'MANAGE_SELL_OFFER_SELL_NOT_AUTHORIZED{} + = (-4, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageSellOfferResult'MANAGE_SELL_OFFER_BUY_NOT_AUTHORIZED{} + = (-5, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageSellOfferResult'MANAGE_SELL_OFFER_LINE_FULL{} + = (-6, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageSellOfferResult'MANAGE_SELL_OFFER_UNDERFUNDED{} + = (-7, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageSellOfferResult'MANAGE_SELL_OFFER_CROSS_SELF{} + = (-8, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageSellOfferResult'MANAGE_SELL_OFFER_SELL_NO_ISSUER{} + = (-9, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageSellOfferResult'MANAGE_SELL_OFFER_BUY_NO_ISSUER{} + = (-10, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageSellOfferResult'MANAGE_SELL_OFFER_NOT_FOUND{} + = (-11, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageSellOfferResult'MANAGE_SELL_OFFER_LOW_RESERVE{} + = (-12, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure + ManageSellOfferResult'MANAGE_SELL_OFFER_SUCCESS + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm (-1) + = Control.Applicative.pure + ManageSellOfferResult'MANAGE_SELL_OFFER_MALFORMED + xdrGetUnionArm (-2) + = Control.Applicative.pure + ManageSellOfferResult'MANAGE_SELL_OFFER_SELL_NO_TRUST + xdrGetUnionArm (-3) + = Control.Applicative.pure + ManageSellOfferResult'MANAGE_SELL_OFFER_BUY_NO_TRUST + xdrGetUnionArm (-4) + = Control.Applicative.pure + ManageSellOfferResult'MANAGE_SELL_OFFER_SELL_NOT_AUTHORIZED + xdrGetUnionArm (-5) + = Control.Applicative.pure + ManageSellOfferResult'MANAGE_SELL_OFFER_BUY_NOT_AUTHORIZED + xdrGetUnionArm (-6) + = Control.Applicative.pure + ManageSellOfferResult'MANAGE_SELL_OFFER_LINE_FULL + xdrGetUnionArm (-7) + = Control.Applicative.pure + ManageSellOfferResult'MANAGE_SELL_OFFER_UNDERFUNDED + xdrGetUnionArm (-8) + = Control.Applicative.pure + ManageSellOfferResult'MANAGE_SELL_OFFER_CROSS_SELF + xdrGetUnionArm (-9) + = Control.Applicative.pure + ManageSellOfferResult'MANAGE_SELL_OFFER_SELL_NO_ISSUER + xdrGetUnionArm (-10) + = Control.Applicative.pure + ManageSellOfferResult'MANAGE_SELL_OFFER_BUY_NO_ISSUER + xdrGetUnionArm (-11) + = Control.Applicative.pure + ManageSellOfferResult'MANAGE_SELL_OFFER_NOT_FOUND + xdrGetUnionArm (-12) + = Control.Applicative.pure + ManageSellOfferResult'MANAGE_SELL_OFFER_LOW_RESERVE + xdrGetUnionArm _c + = Prelude.fail "invalid ManageSellOfferResult discriminant" + +data ManageBuyOfferResultCode = MANAGE_BUY_OFFER_SUCCESS + | MANAGE_BUY_OFFER_MALFORMED + | MANAGE_BUY_OFFER_SELL_NO_TRUST + | MANAGE_BUY_OFFER_BUY_NO_TRUST + | MANAGE_BUY_OFFER_SELL_NOT_AUTHORIZED + | MANAGE_BUY_OFFER_BUY_NOT_AUTHORIZED + | MANAGE_BUY_OFFER_LINE_FULL + | MANAGE_BUY_OFFER_UNDERFUNDED + | MANAGE_BUY_OFFER_CROSS_SELF + | MANAGE_BUY_OFFER_SELL_NO_ISSUER + | MANAGE_BUY_OFFER_BUY_NO_ISSUER + | MANAGE_BUY_OFFER_NOT_FOUND + | MANAGE_BUY_OFFER_LOW_RESERVE + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR ManageBuyOfferResultCode where + xdrType _ = "ManageBuyOfferResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum ManageBuyOfferResultCode where + xdrFromEnum MANAGE_BUY_OFFER_SUCCESS = 0 + xdrFromEnum MANAGE_BUY_OFFER_MALFORMED = -1 + xdrFromEnum MANAGE_BUY_OFFER_SELL_NO_TRUST = -2 + xdrFromEnum MANAGE_BUY_OFFER_BUY_NO_TRUST = -3 + xdrFromEnum MANAGE_BUY_OFFER_SELL_NOT_AUTHORIZED = -4 + xdrFromEnum MANAGE_BUY_OFFER_BUY_NOT_AUTHORIZED = -5 + xdrFromEnum MANAGE_BUY_OFFER_LINE_FULL = -6 + xdrFromEnum MANAGE_BUY_OFFER_UNDERFUNDED = -7 + xdrFromEnum MANAGE_BUY_OFFER_CROSS_SELF = -8 + xdrFromEnum MANAGE_BUY_OFFER_SELL_NO_ISSUER = -9 + xdrFromEnum MANAGE_BUY_OFFER_BUY_NO_ISSUER = -10 + xdrFromEnum MANAGE_BUY_OFFER_NOT_FOUND = -11 + xdrFromEnum MANAGE_BUY_OFFER_LOW_RESERVE = -12 + xdrToEnum 0 = Prelude.return MANAGE_BUY_OFFER_SUCCESS + xdrToEnum (-1) = Prelude.return MANAGE_BUY_OFFER_MALFORMED + xdrToEnum (-2) = Prelude.return MANAGE_BUY_OFFER_SELL_NO_TRUST + xdrToEnum (-3) = Prelude.return MANAGE_BUY_OFFER_BUY_NO_TRUST + xdrToEnum (-4) + = Prelude.return MANAGE_BUY_OFFER_SELL_NOT_AUTHORIZED + xdrToEnum (-5) = Prelude.return MANAGE_BUY_OFFER_BUY_NOT_AUTHORIZED + xdrToEnum (-6) = Prelude.return MANAGE_BUY_OFFER_LINE_FULL + xdrToEnum (-7) = Prelude.return MANAGE_BUY_OFFER_UNDERFUNDED + xdrToEnum (-8) = Prelude.return MANAGE_BUY_OFFER_CROSS_SELF + xdrToEnum (-9) = Prelude.return MANAGE_BUY_OFFER_SELL_NO_ISSUER + xdrToEnum (-10) = Prelude.return MANAGE_BUY_OFFER_BUY_NO_ISSUER + xdrToEnum (-11) = Prelude.return MANAGE_BUY_OFFER_NOT_FOUND + xdrToEnum (-12) = Prelude.return MANAGE_BUY_OFFER_LOW_RESERVE + xdrToEnum _ = Prelude.fail "invalid ManageBuyOfferResultCode" + +data ManageBuyOfferResult = ManageBuyOfferResult'MANAGE_BUY_OFFER_SUCCESS{manageBuyOfferResult'success + :: + !ManageOfferSuccessResult} + | ManageBuyOfferResult'MANAGE_BUY_OFFER_MALFORMED{} + | ManageBuyOfferResult'MANAGE_BUY_OFFER_SELL_NO_TRUST{} + | ManageBuyOfferResult'MANAGE_BUY_OFFER_BUY_NO_TRUST{} + | ManageBuyOfferResult'MANAGE_BUY_OFFER_SELL_NOT_AUTHORIZED{} + | ManageBuyOfferResult'MANAGE_BUY_OFFER_BUY_NOT_AUTHORIZED{} + | ManageBuyOfferResult'MANAGE_BUY_OFFER_LINE_FULL{} + | ManageBuyOfferResult'MANAGE_BUY_OFFER_UNDERFUNDED{} + | ManageBuyOfferResult'MANAGE_BUY_OFFER_CROSS_SELF{} + | ManageBuyOfferResult'MANAGE_BUY_OFFER_SELL_NO_ISSUER{} + | ManageBuyOfferResult'MANAGE_BUY_OFFER_BUY_NO_ISSUER{} + | ManageBuyOfferResult'MANAGE_BUY_OFFER_NOT_FOUND{} + | ManageBuyOfferResult'MANAGE_BUY_OFFER_LOW_RESERVE{} + deriving (Prelude.Eq, Prelude.Show) + +manageBuyOfferResult'code :: + ManageBuyOfferResult -> ManageBuyOfferResultCode +manageBuyOfferResult'code = XDR.xdrDiscriminant + +instance XDR.XDR ManageBuyOfferResult where + xdrType _ = "ManageBuyOfferResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion ManageBuyOfferResult where + type XDRDiscriminant ManageBuyOfferResult = + ManageBuyOfferResultCode + xdrSplitUnion _x@ManageBuyOfferResult'MANAGE_BUY_OFFER_SUCCESS{} + = (0, XDR.xdrPut (manageBuyOfferResult'success _x)) + xdrSplitUnion _x@ManageBuyOfferResult'MANAGE_BUY_OFFER_MALFORMED{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageBuyOfferResult'MANAGE_BUY_OFFER_SELL_NO_TRUST{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageBuyOfferResult'MANAGE_BUY_OFFER_BUY_NO_TRUST{} + = (-3, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageBuyOfferResult'MANAGE_BUY_OFFER_SELL_NOT_AUTHORIZED{} + = (-4, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageBuyOfferResult'MANAGE_BUY_OFFER_BUY_NOT_AUTHORIZED{} + = (-5, Control.Applicative.pure ()) + xdrSplitUnion _x@ManageBuyOfferResult'MANAGE_BUY_OFFER_LINE_FULL{} + = (-6, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageBuyOfferResult'MANAGE_BUY_OFFER_UNDERFUNDED{} + = (-7, Control.Applicative.pure ()) + xdrSplitUnion _x@ManageBuyOfferResult'MANAGE_BUY_OFFER_CROSS_SELF{} + = (-8, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageBuyOfferResult'MANAGE_BUY_OFFER_SELL_NO_ISSUER{} + = (-9, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageBuyOfferResult'MANAGE_BUY_OFFER_BUY_NO_ISSUER{} + = (-10, Control.Applicative.pure ()) + xdrSplitUnion _x@ManageBuyOfferResult'MANAGE_BUY_OFFER_NOT_FOUND{} + = (-11, Control.Applicative.pure ()) + xdrSplitUnion + _x@ManageBuyOfferResult'MANAGE_BUY_OFFER_LOW_RESERVE{} + = (-12, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure + ManageBuyOfferResult'MANAGE_BUY_OFFER_SUCCESS + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm (-1) + = Control.Applicative.pure + ManageBuyOfferResult'MANAGE_BUY_OFFER_MALFORMED + xdrGetUnionArm (-2) + = Control.Applicative.pure + ManageBuyOfferResult'MANAGE_BUY_OFFER_SELL_NO_TRUST + xdrGetUnionArm (-3) + = Control.Applicative.pure + ManageBuyOfferResult'MANAGE_BUY_OFFER_BUY_NO_TRUST + xdrGetUnionArm (-4) + = Control.Applicative.pure + ManageBuyOfferResult'MANAGE_BUY_OFFER_SELL_NOT_AUTHORIZED + xdrGetUnionArm (-5) + = Control.Applicative.pure + ManageBuyOfferResult'MANAGE_BUY_OFFER_BUY_NOT_AUTHORIZED + xdrGetUnionArm (-6) + = Control.Applicative.pure + ManageBuyOfferResult'MANAGE_BUY_OFFER_LINE_FULL + xdrGetUnionArm (-7) + = Control.Applicative.pure + ManageBuyOfferResult'MANAGE_BUY_OFFER_UNDERFUNDED + xdrGetUnionArm (-8) + = Control.Applicative.pure + ManageBuyOfferResult'MANAGE_BUY_OFFER_CROSS_SELF + xdrGetUnionArm (-9) + = Control.Applicative.pure + ManageBuyOfferResult'MANAGE_BUY_OFFER_SELL_NO_ISSUER + xdrGetUnionArm (-10) + = Control.Applicative.pure + ManageBuyOfferResult'MANAGE_BUY_OFFER_BUY_NO_ISSUER + xdrGetUnionArm (-11) + = Control.Applicative.pure + ManageBuyOfferResult'MANAGE_BUY_OFFER_NOT_FOUND + xdrGetUnionArm (-12) + = Control.Applicative.pure + ManageBuyOfferResult'MANAGE_BUY_OFFER_LOW_RESERVE + xdrGetUnionArm _c + = Prelude.fail "invalid ManageBuyOfferResult discriminant" + +data SetOptionsResultCode = SET_OPTIONS_SUCCESS + | SET_OPTIONS_LOW_RESERVE + | SET_OPTIONS_TOO_MANY_SIGNERS + | SET_OPTIONS_BAD_FLAGS + | SET_OPTIONS_INVALID_INFLATION + | SET_OPTIONS_CANT_CHANGE + | SET_OPTIONS_UNKNOWN_FLAG + | SET_OPTIONS_THRESHOLD_OUT_OF_RANGE + | SET_OPTIONS_BAD_SIGNER + | SET_OPTIONS_INVALID_HOME_DOMAIN + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR SetOptionsResultCode where + xdrType _ = "SetOptionsResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum SetOptionsResultCode where + xdrFromEnum SET_OPTIONS_SUCCESS = 0 + xdrFromEnum SET_OPTIONS_LOW_RESERVE = -1 + xdrFromEnum SET_OPTIONS_TOO_MANY_SIGNERS = -2 + xdrFromEnum SET_OPTIONS_BAD_FLAGS = -3 + xdrFromEnum SET_OPTIONS_INVALID_INFLATION = -4 + xdrFromEnum SET_OPTIONS_CANT_CHANGE = -5 + xdrFromEnum SET_OPTIONS_UNKNOWN_FLAG = -6 + xdrFromEnum SET_OPTIONS_THRESHOLD_OUT_OF_RANGE = -7 + xdrFromEnum SET_OPTIONS_BAD_SIGNER = -8 + xdrFromEnum SET_OPTIONS_INVALID_HOME_DOMAIN = -9 + xdrToEnum 0 = Prelude.return SET_OPTIONS_SUCCESS + xdrToEnum (-1) = Prelude.return SET_OPTIONS_LOW_RESERVE + xdrToEnum (-2) = Prelude.return SET_OPTIONS_TOO_MANY_SIGNERS + xdrToEnum (-3) = Prelude.return SET_OPTIONS_BAD_FLAGS + xdrToEnum (-4) = Prelude.return SET_OPTIONS_INVALID_INFLATION + xdrToEnum (-5) = Prelude.return SET_OPTIONS_CANT_CHANGE + xdrToEnum (-6) = Prelude.return SET_OPTIONS_UNKNOWN_FLAG + xdrToEnum (-7) = Prelude.return SET_OPTIONS_THRESHOLD_OUT_OF_RANGE + xdrToEnum (-8) = Prelude.return SET_OPTIONS_BAD_SIGNER + xdrToEnum (-9) = Prelude.return SET_OPTIONS_INVALID_HOME_DOMAIN + xdrToEnum _ = Prelude.fail "invalid SetOptionsResultCode" + +data SetOptionsResult = SetOptionsResult'SET_OPTIONS_SUCCESS{} + | SetOptionsResult'default{setOptionsResult'code' :: + !SetOptionsResultCode} + deriving (Prelude.Eq, Prelude.Show) + +setOptionsResult'code :: SetOptionsResult -> SetOptionsResultCode +setOptionsResult'code = XDR.xdrDiscriminant + +instance XDR.XDR SetOptionsResult where + xdrType _ = "SetOptionsResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion SetOptionsResult where + type XDRDiscriminant SetOptionsResult = SetOptionsResultCode + xdrSplitUnion _x@SetOptionsResult'SET_OPTIONS_SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion + _x@SetOptionsResult'default{setOptionsResult'code' = d} + = (XDR.xdrFromEnum d, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure SetOptionsResult'SET_OPTIONS_SUCCESS + xdrGetUnionArm _c + = SetOptionsResult'default Control.Applicative.<$> XDR.xdrToEnum _c + +data ChangeTrustResultCode = CHANGE_TRUST_SUCCESS + | CHANGE_TRUST_MALFORMED + | CHANGE_TRUST_NO_ISSUER + | CHANGE_TRUST_INVALID_LIMIT + | CHANGE_TRUST_LOW_RESERVE + | CHANGE_TRUST_SELF_NOT_ALLOWED + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR ChangeTrustResultCode where + xdrType _ = "ChangeTrustResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum ChangeTrustResultCode where + xdrFromEnum CHANGE_TRUST_SUCCESS = 0 + xdrFromEnum CHANGE_TRUST_MALFORMED = -1 + xdrFromEnum CHANGE_TRUST_NO_ISSUER = -2 + xdrFromEnum CHANGE_TRUST_INVALID_LIMIT = -3 + xdrFromEnum CHANGE_TRUST_LOW_RESERVE = -4 + xdrFromEnum CHANGE_TRUST_SELF_NOT_ALLOWED = -5 + xdrToEnum 0 = Prelude.return CHANGE_TRUST_SUCCESS + xdrToEnum (-1) = Prelude.return CHANGE_TRUST_MALFORMED + xdrToEnum (-2) = Prelude.return CHANGE_TRUST_NO_ISSUER + xdrToEnum (-3) = Prelude.return CHANGE_TRUST_INVALID_LIMIT + xdrToEnum (-4) = Prelude.return CHANGE_TRUST_LOW_RESERVE + xdrToEnum (-5) = Prelude.return CHANGE_TRUST_SELF_NOT_ALLOWED + xdrToEnum _ = Prelude.fail "invalid ChangeTrustResultCode" + +data ChangeTrustResult = ChangeTrustResult'CHANGE_TRUST_SUCCESS{} + | ChangeTrustResult'default{changeTrustResult'code' :: + !ChangeTrustResultCode} + deriving (Prelude.Eq, Prelude.Show) + +changeTrustResult'code :: + ChangeTrustResult -> ChangeTrustResultCode +changeTrustResult'code = XDR.xdrDiscriminant + +instance XDR.XDR ChangeTrustResult where + xdrType _ = "ChangeTrustResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion ChangeTrustResult where + type XDRDiscriminant ChangeTrustResult = ChangeTrustResultCode + xdrSplitUnion _x@ChangeTrustResult'CHANGE_TRUST_SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion + _x@ChangeTrustResult'default{changeTrustResult'code' = d} + = (XDR.xdrFromEnum d, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure ChangeTrustResult'CHANGE_TRUST_SUCCESS + xdrGetUnionArm _c + = ChangeTrustResult'default Control.Applicative.<$> + XDR.xdrToEnum _c + +data AllowTrustResultCode = ALLOW_TRUST_SUCCESS + | ALLOW_TRUST_MALFORMED + | ALLOW_TRUST_NO_TRUST_LINE + | ALLOW_TRUST_TRUST_NOT_REQUIRED + | ALLOW_TRUST_CANT_REVOKE + | ALLOW_TRUST_SELF_NOT_ALLOWED + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR AllowTrustResultCode where + xdrType _ = "AllowTrustResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum AllowTrustResultCode where + xdrFromEnum ALLOW_TRUST_SUCCESS = 0 + xdrFromEnum ALLOW_TRUST_MALFORMED = -1 + xdrFromEnum ALLOW_TRUST_NO_TRUST_LINE = -2 + xdrFromEnum ALLOW_TRUST_TRUST_NOT_REQUIRED = -3 + xdrFromEnum ALLOW_TRUST_CANT_REVOKE = -4 + xdrFromEnum ALLOW_TRUST_SELF_NOT_ALLOWED = -5 + xdrToEnum 0 = Prelude.return ALLOW_TRUST_SUCCESS + xdrToEnum (-1) = Prelude.return ALLOW_TRUST_MALFORMED + xdrToEnum (-2) = Prelude.return ALLOW_TRUST_NO_TRUST_LINE + xdrToEnum (-3) = Prelude.return ALLOW_TRUST_TRUST_NOT_REQUIRED + xdrToEnum (-4) = Prelude.return ALLOW_TRUST_CANT_REVOKE + xdrToEnum (-5) = Prelude.return ALLOW_TRUST_SELF_NOT_ALLOWED + xdrToEnum _ = Prelude.fail "invalid AllowTrustResultCode" + +data AllowTrustResult = AllowTrustResult'ALLOW_TRUST_SUCCESS{} + | AllowTrustResult'default{allowTrustResult'code' :: + !AllowTrustResultCode} + deriving (Prelude.Eq, Prelude.Show) + +allowTrustResult'code :: AllowTrustResult -> AllowTrustResultCode +allowTrustResult'code = XDR.xdrDiscriminant + +instance XDR.XDR AllowTrustResult where + xdrType _ = "AllowTrustResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion AllowTrustResult where + type XDRDiscriminant AllowTrustResult = AllowTrustResultCode + xdrSplitUnion _x@AllowTrustResult'ALLOW_TRUST_SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion + _x@AllowTrustResult'default{allowTrustResult'code' = d} + = (XDR.xdrFromEnum d, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure AllowTrustResult'ALLOW_TRUST_SUCCESS + xdrGetUnionArm _c + = AllowTrustResult'default Control.Applicative.<$> XDR.xdrToEnum _c + +data AccountMergeResultCode = ACCOUNT_MERGE_SUCCESS + | ACCOUNT_MERGE_MALFORMED + | ACCOUNT_MERGE_NO_ACCOUNT + | ACCOUNT_MERGE_IMMUTABLE_SET + | ACCOUNT_MERGE_HAS_SUB_ENTRIES + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR AccountMergeResultCode where + xdrType _ = "AccountMergeResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum AccountMergeResultCode where + xdrFromEnum ACCOUNT_MERGE_SUCCESS = 0 + xdrFromEnum ACCOUNT_MERGE_MALFORMED = -1 + xdrFromEnum ACCOUNT_MERGE_NO_ACCOUNT = -2 + xdrFromEnum ACCOUNT_MERGE_IMMUTABLE_SET = -3 + xdrFromEnum ACCOUNT_MERGE_HAS_SUB_ENTRIES = -4 + xdrToEnum 0 = Prelude.return ACCOUNT_MERGE_SUCCESS + xdrToEnum (-1) = Prelude.return ACCOUNT_MERGE_MALFORMED + xdrToEnum (-2) = Prelude.return ACCOUNT_MERGE_NO_ACCOUNT + xdrToEnum (-3) = Prelude.return ACCOUNT_MERGE_IMMUTABLE_SET + xdrToEnum (-4) = Prelude.return ACCOUNT_MERGE_HAS_SUB_ENTRIES + xdrToEnum _ = Prelude.fail "invalid AccountMergeResultCode" + +data AccountMergeResult = AccountMergeResult'ACCOUNT_MERGE_SUCCESS{accountMergeResult'sourceAccountBalance + :: !Int64} + | AccountMergeResult'default{accountMergeResult'code' :: + !AccountMergeResultCode} + deriving (Prelude.Eq, Prelude.Show) + +accountMergeResult'code :: + AccountMergeResult -> AccountMergeResultCode +accountMergeResult'code = XDR.xdrDiscriminant + +instance XDR.XDR AccountMergeResult where + xdrType _ = "AccountMergeResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion AccountMergeResult where + type XDRDiscriminant AccountMergeResult = AccountMergeResultCode + xdrSplitUnion _x@AccountMergeResult'ACCOUNT_MERGE_SUCCESS{} + = (0, XDR.xdrPut (accountMergeResult'sourceAccountBalance _x)) + xdrSplitUnion + _x@AccountMergeResult'default{accountMergeResult'code' = d} + = (XDR.xdrFromEnum d, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure AccountMergeResult'ACCOUNT_MERGE_SUCCESS + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = AccountMergeResult'default Control.Applicative.<$> + XDR.xdrToEnum _c + +data InflationResultCode = INFLATION_SUCCESS + | INFLATION_NOT_TIME + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR InflationResultCode where + xdrType _ = "InflationResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum InflationResultCode where + xdrFromEnum INFLATION_SUCCESS = 0 + xdrFromEnum INFLATION_NOT_TIME = -1 + xdrToEnum 0 = Prelude.return INFLATION_SUCCESS + xdrToEnum (-1) = Prelude.return INFLATION_NOT_TIME + xdrToEnum _ = Prelude.fail "invalid InflationResultCode" + +data InflationPayout = InflationPayout{inflationPayout'destination + :: !AccountID, + inflationPayout'amount :: !Int64} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR InflationPayout where + xdrType _ = "InflationPayout" + xdrPut _x + = XDR.xdrPut (inflationPayout'destination _x) + Control.Applicative.*> XDR.xdrPut (inflationPayout'amount _x) + xdrGet + = Control.Applicative.pure InflationPayout Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data InflationResult = InflationResult'INFLATION_SUCCESS{inflationResult'payouts + :: !(XDR.Array 4294967295 InflationPayout)} + | InflationResult'default{inflationResult'code' :: + !InflationResultCode} + deriving (Prelude.Eq, Prelude.Show) + +inflationResult'code :: InflationResult -> InflationResultCode +inflationResult'code = XDR.xdrDiscriminant + +instance XDR.XDR InflationResult where + xdrType _ = "InflationResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion InflationResult where + type XDRDiscriminant InflationResult = InflationResultCode + xdrSplitUnion _x@InflationResult'INFLATION_SUCCESS{} + = (0, XDR.xdrPut (inflationResult'payouts _x)) + xdrSplitUnion _x@InflationResult'default{inflationResult'code' = d} + = (XDR.xdrFromEnum d, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure InflationResult'INFLATION_SUCCESS + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = InflationResult'default Control.Applicative.<$> XDR.xdrToEnum _c + +data ManageDataResultCode = MANAGE_DATA_SUCCESS + | MANAGE_DATA_NOT_SUPPORTED_YET + | MANAGE_DATA_NAME_NOT_FOUND + | MANAGE_DATA_LOW_RESERVE + | MANAGE_DATA_INVALID_NAME + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR ManageDataResultCode where + xdrType _ = "ManageDataResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum ManageDataResultCode where + xdrFromEnum MANAGE_DATA_SUCCESS = 0 + xdrFromEnum MANAGE_DATA_NOT_SUPPORTED_YET = -1 + xdrFromEnum MANAGE_DATA_NAME_NOT_FOUND = -2 + xdrFromEnum MANAGE_DATA_LOW_RESERVE = -3 + xdrFromEnum MANAGE_DATA_INVALID_NAME = -4 + xdrToEnum 0 = Prelude.return MANAGE_DATA_SUCCESS + xdrToEnum (-1) = Prelude.return MANAGE_DATA_NOT_SUPPORTED_YET + xdrToEnum (-2) = Prelude.return MANAGE_DATA_NAME_NOT_FOUND + xdrToEnum (-3) = Prelude.return MANAGE_DATA_LOW_RESERVE + xdrToEnum (-4) = Prelude.return MANAGE_DATA_INVALID_NAME + xdrToEnum _ = Prelude.fail "invalid ManageDataResultCode" + +data ManageDataResult = ManageDataResult'MANAGE_DATA_SUCCESS{} + | ManageDataResult'MANAGE_DATA_NOT_SUPPORTED_YET{} + | ManageDataResult'MANAGE_DATA_NAME_NOT_FOUND{} + | ManageDataResult'MANAGE_DATA_LOW_RESERVE{} + | ManageDataResult'MANAGE_DATA_INVALID_NAME{} + deriving (Prelude.Eq, Prelude.Show) + +manageDataResult'code :: ManageDataResult -> ManageDataResultCode +manageDataResult'code = XDR.xdrDiscriminant + +instance XDR.XDR ManageDataResult where + xdrType _ = "ManageDataResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion ManageDataResult where + type XDRDiscriminant ManageDataResult = ManageDataResultCode + xdrSplitUnion _x@ManageDataResult'MANAGE_DATA_SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion _x@ManageDataResult'MANAGE_DATA_NOT_SUPPORTED_YET{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion _x@ManageDataResult'MANAGE_DATA_NAME_NOT_FOUND{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion _x@ManageDataResult'MANAGE_DATA_LOW_RESERVE{} + = (-3, Control.Applicative.pure ()) + xdrSplitUnion _x@ManageDataResult'MANAGE_DATA_INVALID_NAME{} + = (-4, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure ManageDataResult'MANAGE_DATA_SUCCESS + xdrGetUnionArm (-1) + = Control.Applicative.pure + ManageDataResult'MANAGE_DATA_NOT_SUPPORTED_YET + xdrGetUnionArm (-2) + = Control.Applicative.pure + ManageDataResult'MANAGE_DATA_NAME_NOT_FOUND + xdrGetUnionArm (-3) + = Control.Applicative.pure ManageDataResult'MANAGE_DATA_LOW_RESERVE + xdrGetUnionArm (-4) + = Control.Applicative.pure + ManageDataResult'MANAGE_DATA_INVALID_NAME + xdrGetUnionArm _c + = Prelude.fail "invalid ManageDataResult discriminant" + +data BumpSequenceResultCode = BUMP_SEQUENCE_SUCCESS + | BUMP_SEQUENCE_BAD_SEQ + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR BumpSequenceResultCode where + xdrType _ = "BumpSequenceResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum BumpSequenceResultCode where + xdrFromEnum BUMP_SEQUENCE_SUCCESS = 0 + xdrFromEnum BUMP_SEQUENCE_BAD_SEQ = -1 + xdrToEnum 0 = Prelude.return BUMP_SEQUENCE_SUCCESS + xdrToEnum (-1) = Prelude.return BUMP_SEQUENCE_BAD_SEQ + xdrToEnum _ = Prelude.fail "invalid BumpSequenceResultCode" + +data BumpSequenceResult = BumpSequenceResult'BUMP_SEQUENCE_SUCCESS{} + | BumpSequenceResult'BUMP_SEQUENCE_BAD_SEQ{} + deriving (Prelude.Eq, Prelude.Show) + +bumpSequenceResult'code :: + BumpSequenceResult -> BumpSequenceResultCode +bumpSequenceResult'code = XDR.xdrDiscriminant + +instance XDR.XDR BumpSequenceResult where + xdrType _ = "BumpSequenceResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion BumpSequenceResult where + type XDRDiscriminant BumpSequenceResult = BumpSequenceResultCode + xdrSplitUnion _x@BumpSequenceResult'BUMP_SEQUENCE_SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion _x@BumpSequenceResult'BUMP_SEQUENCE_BAD_SEQ{} + = (-1, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure BumpSequenceResult'BUMP_SEQUENCE_SUCCESS + xdrGetUnionArm (-1) + = Control.Applicative.pure BumpSequenceResult'BUMP_SEQUENCE_BAD_SEQ + xdrGetUnionArm _c + = Prelude.fail "invalid BumpSequenceResult discriminant" + +data CreateClaimableBalanceResultCode = CREATE_CLAIMABLE_BALANCE_SUCCESS + | CREATE_CLAIMABLE_BALANCE_MALFORMED + | CREATE_CLAIMABLE_BALANCE_LOW_RESERVE + | CREATE_CLAIMABLE_BALANCE_NO_TRUST + | CREATE_CLAIMABLE_BALANCE_NOT_AUTHORIZED + | CREATE_CLAIMABLE_BALANCE_UNDERFUNDED + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, + Prelude.Bounded, Prelude.Show) + +instance XDR.XDR CreateClaimableBalanceResultCode where + xdrType _ = "CreateClaimableBalanceResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum CreateClaimableBalanceResultCode where + xdrFromEnum CREATE_CLAIMABLE_BALANCE_SUCCESS = 0 + xdrFromEnum CREATE_CLAIMABLE_BALANCE_MALFORMED = -1 + xdrFromEnum CREATE_CLAIMABLE_BALANCE_LOW_RESERVE = -2 + xdrFromEnum CREATE_CLAIMABLE_BALANCE_NO_TRUST = -3 + xdrFromEnum CREATE_CLAIMABLE_BALANCE_NOT_AUTHORIZED = -4 + xdrFromEnum CREATE_CLAIMABLE_BALANCE_UNDERFUNDED = -5 + xdrToEnum 0 = Prelude.return CREATE_CLAIMABLE_BALANCE_SUCCESS + xdrToEnum (-1) = Prelude.return CREATE_CLAIMABLE_BALANCE_MALFORMED + xdrToEnum (-2) + = Prelude.return CREATE_CLAIMABLE_BALANCE_LOW_RESERVE + xdrToEnum (-3) = Prelude.return CREATE_CLAIMABLE_BALANCE_NO_TRUST + xdrToEnum (-4) + = Prelude.return CREATE_CLAIMABLE_BALANCE_NOT_AUTHORIZED + xdrToEnum (-5) + = Prelude.return CREATE_CLAIMABLE_BALANCE_UNDERFUNDED + xdrToEnum _ + = Prelude.fail "invalid CreateClaimableBalanceResultCode" + +data CreateClaimableBalanceResult = CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_SUCCESS{createClaimableBalanceResult'balanceID + :: + !ClaimableBalanceID} + | CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_MALFORMED{} + | CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_LOW_RESERVE{} + | CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_NO_TRUST{} + | CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_NOT_AUTHORIZED{} + | CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_UNDERFUNDED{} + deriving (Prelude.Eq, Prelude.Show) + +createClaimableBalanceResult'code :: + CreateClaimableBalanceResult -> CreateClaimableBalanceResultCode +createClaimableBalanceResult'code = XDR.xdrDiscriminant + +instance XDR.XDR CreateClaimableBalanceResult where + xdrType _ = "CreateClaimableBalanceResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion CreateClaimableBalanceResult where + type XDRDiscriminant CreateClaimableBalanceResult = + CreateClaimableBalanceResultCode + xdrSplitUnion + _x@CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_SUCCESS{} + = (0, XDR.xdrPut (createClaimableBalanceResult'balanceID _x)) + xdrSplitUnion + _x@CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_MALFORMED{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion + _x@CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_LOW_RESERVE{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion + _x@CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_NO_TRUST{} + = (-3, Control.Applicative.pure ()) + xdrSplitUnion + _x@CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_NOT_AUTHORIZED{} + = (-4, Control.Applicative.pure ()) + xdrSplitUnion + _x@CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_UNDERFUNDED{} + = (-5, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure + CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_SUCCESS + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm (-1) + = Control.Applicative.pure + CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_MALFORMED + xdrGetUnionArm (-2) + = Control.Applicative.pure + CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_LOW_RESERVE + xdrGetUnionArm (-3) + = Control.Applicative.pure + CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_NO_TRUST + xdrGetUnionArm (-4) + = Control.Applicative.pure + CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_NOT_AUTHORIZED + xdrGetUnionArm (-5) + = Control.Applicative.pure + CreateClaimableBalanceResult'CREATE_CLAIMABLE_BALANCE_UNDERFUNDED + xdrGetUnionArm _c + = Prelude.fail "invalid CreateClaimableBalanceResult discriminant" + +data ClaimClaimableBalanceResultCode = CLAIM_CLAIMABLE_BALANCE_SUCCESS + | CLAIM_CLAIMABLE_BALANCE_DOES_NOT_EXIST + | CLAIM_CLAIMABLE_BALANCE_CANNOT_CLAIM + | CLAIM_CLAIMABLE_BALANCE_LINE_FULL + | CLAIM_CLAIMABLE_BALANCE_NO_TRUST + | CLAIM_CLAIMABLE_BALANCE_NOT_AUTHORIZED + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, + Prelude.Bounded, Prelude.Show) + +instance XDR.XDR ClaimClaimableBalanceResultCode where + xdrType _ = "ClaimClaimableBalanceResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum ClaimClaimableBalanceResultCode where + xdrFromEnum CLAIM_CLAIMABLE_BALANCE_SUCCESS = 0 + xdrFromEnum CLAIM_CLAIMABLE_BALANCE_DOES_NOT_EXIST = -1 + xdrFromEnum CLAIM_CLAIMABLE_BALANCE_CANNOT_CLAIM = -2 + xdrFromEnum CLAIM_CLAIMABLE_BALANCE_LINE_FULL = -3 + xdrFromEnum CLAIM_CLAIMABLE_BALANCE_NO_TRUST = -4 + xdrFromEnum CLAIM_CLAIMABLE_BALANCE_NOT_AUTHORIZED = -5 + xdrToEnum 0 = Prelude.return CLAIM_CLAIMABLE_BALANCE_SUCCESS + xdrToEnum (-1) + = Prelude.return CLAIM_CLAIMABLE_BALANCE_DOES_NOT_EXIST + xdrToEnum (-2) + = Prelude.return CLAIM_CLAIMABLE_BALANCE_CANNOT_CLAIM + xdrToEnum (-3) = Prelude.return CLAIM_CLAIMABLE_BALANCE_LINE_FULL + xdrToEnum (-4) = Prelude.return CLAIM_CLAIMABLE_BALANCE_NO_TRUST + xdrToEnum (-5) + = Prelude.return CLAIM_CLAIMABLE_BALANCE_NOT_AUTHORIZED + xdrToEnum _ + = Prelude.fail "invalid ClaimClaimableBalanceResultCode" + +data ClaimClaimableBalanceResult = ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_SUCCESS{} + | ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_DOES_NOT_EXIST{} + | ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_CANNOT_CLAIM{} + | ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_LINE_FULL{} + | ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_NO_TRUST{} + | ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_NOT_AUTHORIZED{} + deriving (Prelude.Eq, Prelude.Show) + +claimClaimableBalanceResult'code :: + ClaimClaimableBalanceResult -> ClaimClaimableBalanceResultCode +claimClaimableBalanceResult'code = XDR.xdrDiscriminant + +instance XDR.XDR ClaimClaimableBalanceResult where + xdrType _ = "ClaimClaimableBalanceResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion ClaimClaimableBalanceResult where + type XDRDiscriminant ClaimClaimableBalanceResult = + ClaimClaimableBalanceResultCode + xdrSplitUnion + _x@ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion + _x@ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_DOES_NOT_EXIST{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion + _x@ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_CANNOT_CLAIM{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion + _x@ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_LINE_FULL{} + = (-3, Control.Applicative.pure ()) + xdrSplitUnion + _x@ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_NO_TRUST{} + = (-4, Control.Applicative.pure ()) + xdrSplitUnion + _x@ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_NOT_AUTHORIZED{} + = (-5, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure + ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_SUCCESS + xdrGetUnionArm (-1) + = Control.Applicative.pure + ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_DOES_NOT_EXIST + xdrGetUnionArm (-2) + = Control.Applicative.pure + ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_CANNOT_CLAIM + xdrGetUnionArm (-3) + = Control.Applicative.pure + ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_LINE_FULL + xdrGetUnionArm (-4) + = Control.Applicative.pure + ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_NO_TRUST + xdrGetUnionArm (-5) + = Control.Applicative.pure + ClaimClaimableBalanceResult'CLAIM_CLAIMABLE_BALANCE_NOT_AUTHORIZED + xdrGetUnionArm _c + = Prelude.fail "invalid ClaimClaimableBalanceResult discriminant" + +data BeginSponsoringFutureReservesResultCode = BEGIN_SPONSORING_FUTURE_RESERVES_SUCCESS + | BEGIN_SPONSORING_FUTURE_RESERVES_MALFORMED + | BEGIN_SPONSORING_FUTURE_RESERVES_ALREADY_SPONSORED + | BEGIN_SPONSORING_FUTURE_RESERVES_RECURSIVE + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, + Prelude.Bounded, Prelude.Show) + +instance XDR.XDR BeginSponsoringFutureReservesResultCode where + xdrType _ = "BeginSponsoringFutureReservesResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum BeginSponsoringFutureReservesResultCode where + xdrFromEnum BEGIN_SPONSORING_FUTURE_RESERVES_SUCCESS = 0 + xdrFromEnum BEGIN_SPONSORING_FUTURE_RESERVES_MALFORMED = -1 + xdrFromEnum BEGIN_SPONSORING_FUTURE_RESERVES_ALREADY_SPONSORED = -2 + xdrFromEnum BEGIN_SPONSORING_FUTURE_RESERVES_RECURSIVE = -3 + xdrToEnum 0 + = Prelude.return BEGIN_SPONSORING_FUTURE_RESERVES_SUCCESS + xdrToEnum (-1) + = Prelude.return BEGIN_SPONSORING_FUTURE_RESERVES_MALFORMED + xdrToEnum (-2) + = Prelude.return BEGIN_SPONSORING_FUTURE_RESERVES_ALREADY_SPONSORED + xdrToEnum (-3) + = Prelude.return BEGIN_SPONSORING_FUTURE_RESERVES_RECURSIVE + xdrToEnum _ + = Prelude.fail "invalid BeginSponsoringFutureReservesResultCode" + +data BeginSponsoringFutureReservesResult = BeginSponsoringFutureReservesResult'BEGIN_SPONSORING_FUTURE_RESERVES_SUCCESS{} + | BeginSponsoringFutureReservesResult'BEGIN_SPONSORING_FUTURE_RESERVES_MALFORMED{} + | BeginSponsoringFutureReservesResult'BEGIN_SPONSORING_FUTURE_RESERVES_ALREADY_SPONSORED{} + | BeginSponsoringFutureReservesResult'BEGIN_SPONSORING_FUTURE_RESERVES_RECURSIVE{} + deriving (Prelude.Eq, Prelude.Show) + +beginSponsoringFutureReservesResult'code :: + BeginSponsoringFutureReservesResult -> + BeginSponsoringFutureReservesResultCode +beginSponsoringFutureReservesResult'code = XDR.xdrDiscriminant + +instance XDR.XDR BeginSponsoringFutureReservesResult where + xdrType _ = "BeginSponsoringFutureReservesResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion BeginSponsoringFutureReservesResult where + type XDRDiscriminant BeginSponsoringFutureReservesResult = + BeginSponsoringFutureReservesResultCode + xdrSplitUnion + _x@BeginSponsoringFutureReservesResult'BEGIN_SPONSORING_FUTURE_RESERVES_SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion + _x@BeginSponsoringFutureReservesResult'BEGIN_SPONSORING_FUTURE_RESERVES_MALFORMED{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion + _x@BeginSponsoringFutureReservesResult'BEGIN_SPONSORING_FUTURE_RESERVES_ALREADY_SPONSORED{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion + _x@BeginSponsoringFutureReservesResult'BEGIN_SPONSORING_FUTURE_RESERVES_RECURSIVE{} + = (-3, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure + BeginSponsoringFutureReservesResult'BEGIN_SPONSORING_FUTURE_RESERVES_SUCCESS + xdrGetUnionArm (-1) + = Control.Applicative.pure + BeginSponsoringFutureReservesResult'BEGIN_SPONSORING_FUTURE_RESERVES_MALFORMED + xdrGetUnionArm (-2) + = Control.Applicative.pure + BeginSponsoringFutureReservesResult'BEGIN_SPONSORING_FUTURE_RESERVES_ALREADY_SPONSORED + xdrGetUnionArm (-3) + = Control.Applicative.pure + BeginSponsoringFutureReservesResult'BEGIN_SPONSORING_FUTURE_RESERVES_RECURSIVE + xdrGetUnionArm _c + = Prelude.fail + "invalid BeginSponsoringFutureReservesResult discriminant" + +data EndSponsoringFutureReservesResultCode = END_SPONSORING_FUTURE_RESERVES_SUCCESS + | END_SPONSORING_FUTURE_RESERVES_NOT_SPONSORED + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, + Prelude.Bounded, Prelude.Show) + +instance XDR.XDR EndSponsoringFutureReservesResultCode where + xdrType _ = "EndSponsoringFutureReservesResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum EndSponsoringFutureReservesResultCode where + xdrFromEnum END_SPONSORING_FUTURE_RESERVES_SUCCESS = 0 + xdrFromEnum END_SPONSORING_FUTURE_RESERVES_NOT_SPONSORED = -1 + xdrToEnum 0 = Prelude.return END_SPONSORING_FUTURE_RESERVES_SUCCESS + xdrToEnum (-1) + = Prelude.return END_SPONSORING_FUTURE_RESERVES_NOT_SPONSORED + xdrToEnum _ + = Prelude.fail "invalid EndSponsoringFutureReservesResultCode" + +data EndSponsoringFutureReservesResult = EndSponsoringFutureReservesResult'END_SPONSORING_FUTURE_RESERVES_SUCCESS{} + | EndSponsoringFutureReservesResult'END_SPONSORING_FUTURE_RESERVES_NOT_SPONSORED{} + deriving (Prelude.Eq, Prelude.Show) + +endSponsoringFutureReservesResult'code :: + EndSponsoringFutureReservesResult -> + EndSponsoringFutureReservesResultCode +endSponsoringFutureReservesResult'code = XDR.xdrDiscriminant + +instance XDR.XDR EndSponsoringFutureReservesResult where + xdrType _ = "EndSponsoringFutureReservesResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion EndSponsoringFutureReservesResult where + type XDRDiscriminant EndSponsoringFutureReservesResult = + EndSponsoringFutureReservesResultCode + xdrSplitUnion + _x@EndSponsoringFutureReservesResult'END_SPONSORING_FUTURE_RESERVES_SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion + _x@EndSponsoringFutureReservesResult'END_SPONSORING_FUTURE_RESERVES_NOT_SPONSORED{} + = (-1, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure + EndSponsoringFutureReservesResult'END_SPONSORING_FUTURE_RESERVES_SUCCESS + xdrGetUnionArm (-1) + = Control.Applicative.pure + EndSponsoringFutureReservesResult'END_SPONSORING_FUTURE_RESERVES_NOT_SPONSORED + xdrGetUnionArm _c + = Prelude.fail + "invalid EndSponsoringFutureReservesResult discriminant" + +data RevokeSponsorshipResultCode = REVOKE_SPONSORSHIP_SUCCESS + | REVOKE_SPONSORSHIP_DOES_NOT_EXIST + | REVOKE_SPONSORSHIP_NOT_SPONSOR + | REVOKE_SPONSORSHIP_LOW_RESERVE + | REVOKE_SPONSORSHIP_ONLY_TRANSFERABLE + | REVOKE_SPONSORSHIP_MALFORMED + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR RevokeSponsorshipResultCode where + xdrType _ = "RevokeSponsorshipResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum RevokeSponsorshipResultCode where + xdrFromEnum REVOKE_SPONSORSHIP_SUCCESS = 0 + xdrFromEnum REVOKE_SPONSORSHIP_DOES_NOT_EXIST = -1 + xdrFromEnum REVOKE_SPONSORSHIP_NOT_SPONSOR = -2 + xdrFromEnum REVOKE_SPONSORSHIP_LOW_RESERVE = -3 + xdrFromEnum REVOKE_SPONSORSHIP_ONLY_TRANSFERABLE = -4 + xdrFromEnum REVOKE_SPONSORSHIP_MALFORMED = -5 + xdrToEnum 0 = Prelude.return REVOKE_SPONSORSHIP_SUCCESS + xdrToEnum (-1) = Prelude.return REVOKE_SPONSORSHIP_DOES_NOT_EXIST + xdrToEnum (-2) = Prelude.return REVOKE_SPONSORSHIP_NOT_SPONSOR + xdrToEnum (-3) = Prelude.return REVOKE_SPONSORSHIP_LOW_RESERVE + xdrToEnum (-4) + = Prelude.return REVOKE_SPONSORSHIP_ONLY_TRANSFERABLE + xdrToEnum (-5) = Prelude.return REVOKE_SPONSORSHIP_MALFORMED + xdrToEnum _ = Prelude.fail "invalid RevokeSponsorshipResultCode" + +data RevokeSponsorshipResult = RevokeSponsorshipResult'REVOKE_SPONSORSHIP_SUCCESS{} + | RevokeSponsorshipResult'REVOKE_SPONSORSHIP_DOES_NOT_EXIST{} + | RevokeSponsorshipResult'REVOKE_SPONSORSHIP_NOT_SPONSOR{} + | RevokeSponsorshipResult'REVOKE_SPONSORSHIP_LOW_RESERVE{} + | RevokeSponsorshipResult'REVOKE_SPONSORSHIP_ONLY_TRANSFERABLE{} + | RevokeSponsorshipResult'REVOKE_SPONSORSHIP_MALFORMED{} + deriving (Prelude.Eq, Prelude.Show) + +revokeSponsorshipResult'code :: + RevokeSponsorshipResult -> RevokeSponsorshipResultCode +revokeSponsorshipResult'code = XDR.xdrDiscriminant + +instance XDR.XDR RevokeSponsorshipResult where + xdrType _ = "RevokeSponsorshipResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion RevokeSponsorshipResult where + type XDRDiscriminant RevokeSponsorshipResult = + RevokeSponsorshipResultCode + xdrSplitUnion + _x@RevokeSponsorshipResult'REVOKE_SPONSORSHIP_SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion + _x@RevokeSponsorshipResult'REVOKE_SPONSORSHIP_DOES_NOT_EXIST{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion + _x@RevokeSponsorshipResult'REVOKE_SPONSORSHIP_NOT_SPONSOR{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion + _x@RevokeSponsorshipResult'REVOKE_SPONSORSHIP_LOW_RESERVE{} + = (-3, Control.Applicative.pure ()) + xdrSplitUnion + _x@RevokeSponsorshipResult'REVOKE_SPONSORSHIP_ONLY_TRANSFERABLE{} + = (-4, Control.Applicative.pure ()) + xdrSplitUnion + _x@RevokeSponsorshipResult'REVOKE_SPONSORSHIP_MALFORMED{} + = (-5, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure + RevokeSponsorshipResult'REVOKE_SPONSORSHIP_SUCCESS + xdrGetUnionArm (-1) + = Control.Applicative.pure + RevokeSponsorshipResult'REVOKE_SPONSORSHIP_DOES_NOT_EXIST + xdrGetUnionArm (-2) + = Control.Applicative.pure + RevokeSponsorshipResult'REVOKE_SPONSORSHIP_NOT_SPONSOR + xdrGetUnionArm (-3) + = Control.Applicative.pure + RevokeSponsorshipResult'REVOKE_SPONSORSHIP_LOW_RESERVE + xdrGetUnionArm (-4) + = Control.Applicative.pure + RevokeSponsorshipResult'REVOKE_SPONSORSHIP_ONLY_TRANSFERABLE + xdrGetUnionArm (-5) + = Control.Applicative.pure + RevokeSponsorshipResult'REVOKE_SPONSORSHIP_MALFORMED + xdrGetUnionArm _c + = Prelude.fail "invalid RevokeSponsorshipResult discriminant" + +data ClawbackResultCode = CLAWBACK_SUCCESS + | CLAWBACK_MALFORMED + | CLAWBACK_NOT_CLAWBACK_ENABLED + | CLAWBACK_NO_TRUST + | CLAWBACK_UNDERFUNDED + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR ClawbackResultCode where + xdrType _ = "ClawbackResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum ClawbackResultCode where + xdrFromEnum CLAWBACK_SUCCESS = 0 + xdrFromEnum CLAWBACK_MALFORMED = -1 + xdrFromEnum CLAWBACK_NOT_CLAWBACK_ENABLED = -2 + xdrFromEnum CLAWBACK_NO_TRUST = -3 + xdrFromEnum CLAWBACK_UNDERFUNDED = -4 + xdrToEnum 0 = Prelude.return CLAWBACK_SUCCESS + xdrToEnum (-1) = Prelude.return CLAWBACK_MALFORMED + xdrToEnum (-2) = Prelude.return CLAWBACK_NOT_CLAWBACK_ENABLED + xdrToEnum (-3) = Prelude.return CLAWBACK_NO_TRUST + xdrToEnum (-4) = Prelude.return CLAWBACK_UNDERFUNDED + xdrToEnum _ = Prelude.fail "invalid ClawbackResultCode" + +data ClawbackResult = ClawbackResult'CLAWBACK_SUCCESS{} + | ClawbackResult'CLAWBACK_MALFORMED{} + | ClawbackResult'CLAWBACK_NOT_CLAWBACK_ENABLED{} + | ClawbackResult'CLAWBACK_NO_TRUST{} + | ClawbackResult'CLAWBACK_UNDERFUNDED{} + deriving (Prelude.Eq, Prelude.Show) + +clawbackResult'code :: ClawbackResult -> ClawbackResultCode +clawbackResult'code = XDR.xdrDiscriminant + +instance XDR.XDR ClawbackResult where + xdrType _ = "ClawbackResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion ClawbackResult where + type XDRDiscriminant ClawbackResult = ClawbackResultCode + xdrSplitUnion _x@ClawbackResult'CLAWBACK_SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion _x@ClawbackResult'CLAWBACK_MALFORMED{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion _x@ClawbackResult'CLAWBACK_NOT_CLAWBACK_ENABLED{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion _x@ClawbackResult'CLAWBACK_NO_TRUST{} + = (-3, Control.Applicative.pure ()) + xdrSplitUnion _x@ClawbackResult'CLAWBACK_UNDERFUNDED{} + = (-4, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure ClawbackResult'CLAWBACK_SUCCESS + xdrGetUnionArm (-1) + = Control.Applicative.pure ClawbackResult'CLAWBACK_MALFORMED + xdrGetUnionArm (-2) + = Control.Applicative.pure + ClawbackResult'CLAWBACK_NOT_CLAWBACK_ENABLED + xdrGetUnionArm (-3) + = Control.Applicative.pure ClawbackResult'CLAWBACK_NO_TRUST + xdrGetUnionArm (-4) + = Control.Applicative.pure ClawbackResult'CLAWBACK_UNDERFUNDED + xdrGetUnionArm _c + = Prelude.fail "invalid ClawbackResult discriminant" + +data ClawbackClaimableBalanceResultCode = CLAWBACK_CLAIMABLE_BALANCE_SUCCESS + | CLAWBACK_CLAIMABLE_BALANCE_DOES_NOT_EXIST + | CLAWBACK_CLAIMABLE_BALANCE_NOT_ISSUER + | CLAWBACK_CLAIMABLE_BALANCE_NOT_CLAWBACK_ENABLED + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, + Prelude.Bounded, Prelude.Show) + +instance XDR.XDR ClawbackClaimableBalanceResultCode where + xdrType _ = "ClawbackClaimableBalanceResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum ClawbackClaimableBalanceResultCode where + xdrFromEnum CLAWBACK_CLAIMABLE_BALANCE_SUCCESS = 0 + xdrFromEnum CLAWBACK_CLAIMABLE_BALANCE_DOES_NOT_EXIST = -1 + xdrFromEnum CLAWBACK_CLAIMABLE_BALANCE_NOT_ISSUER = -2 + xdrFromEnum CLAWBACK_CLAIMABLE_BALANCE_NOT_CLAWBACK_ENABLED = -3 + xdrToEnum 0 = Prelude.return CLAWBACK_CLAIMABLE_BALANCE_SUCCESS + xdrToEnum (-1) + = Prelude.return CLAWBACK_CLAIMABLE_BALANCE_DOES_NOT_EXIST + xdrToEnum (-2) + = Prelude.return CLAWBACK_CLAIMABLE_BALANCE_NOT_ISSUER + xdrToEnum (-3) + = Prelude.return CLAWBACK_CLAIMABLE_BALANCE_NOT_CLAWBACK_ENABLED + xdrToEnum _ + = Prelude.fail "invalid ClawbackClaimableBalanceResultCode" + +data ClawbackClaimableBalanceResult = ClawbackClaimableBalanceResult'CLAWBACK_CLAIMABLE_BALANCE_SUCCESS{} + | ClawbackClaimableBalanceResult'CLAWBACK_CLAIMABLE_BALANCE_DOES_NOT_EXIST{} + | ClawbackClaimableBalanceResult'CLAWBACK_CLAIMABLE_BALANCE_NOT_ISSUER{} + | ClawbackClaimableBalanceResult'CLAWBACK_CLAIMABLE_BALANCE_NOT_CLAWBACK_ENABLED{} + deriving (Prelude.Eq, Prelude.Show) + +clawbackClaimableBalanceResult'code :: + ClawbackClaimableBalanceResult -> + ClawbackClaimableBalanceResultCode +clawbackClaimableBalanceResult'code = XDR.xdrDiscriminant + +instance XDR.XDR ClawbackClaimableBalanceResult where + xdrType _ = "ClawbackClaimableBalanceResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion ClawbackClaimableBalanceResult where + type XDRDiscriminant ClawbackClaimableBalanceResult = + ClawbackClaimableBalanceResultCode + xdrSplitUnion + _x@ClawbackClaimableBalanceResult'CLAWBACK_CLAIMABLE_BALANCE_SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion + _x@ClawbackClaimableBalanceResult'CLAWBACK_CLAIMABLE_BALANCE_DOES_NOT_EXIST{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion + _x@ClawbackClaimableBalanceResult'CLAWBACK_CLAIMABLE_BALANCE_NOT_ISSUER{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion + _x@ClawbackClaimableBalanceResult'CLAWBACK_CLAIMABLE_BALANCE_NOT_CLAWBACK_ENABLED{} + = (-3, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure + ClawbackClaimableBalanceResult'CLAWBACK_CLAIMABLE_BALANCE_SUCCESS + xdrGetUnionArm (-1) + = Control.Applicative.pure + ClawbackClaimableBalanceResult'CLAWBACK_CLAIMABLE_BALANCE_DOES_NOT_EXIST + xdrGetUnionArm (-2) + = Control.Applicative.pure + ClawbackClaimableBalanceResult'CLAWBACK_CLAIMABLE_BALANCE_NOT_ISSUER + xdrGetUnionArm (-3) + = Control.Applicative.pure + ClawbackClaimableBalanceResult'CLAWBACK_CLAIMABLE_BALANCE_NOT_CLAWBACK_ENABLED + xdrGetUnionArm _c + = Prelude.fail + "invalid ClawbackClaimableBalanceResult discriminant" + +data SetTrustLineFlagsResultCode = SET_TRUST_LINE_FLAGS_SUCCESS + | SET_TRUST_LINE_FLAGS_MALFORMED + | SET_TRUST_LINE_FLAGS_NO_TRUST_LINE + | SET_TRUST_LINE_FLAGS_CANT_REVOKE + | SET_TRUST_LINE_FLAGS_INVALID_STATE + | SET_TRUST_LINE_FLAGS_LOW_RESERVE + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR SetTrustLineFlagsResultCode where + xdrType _ = "SetTrustLineFlagsResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum SetTrustLineFlagsResultCode where + xdrFromEnum SET_TRUST_LINE_FLAGS_SUCCESS = 0 + xdrFromEnum SET_TRUST_LINE_FLAGS_MALFORMED = -1 + xdrFromEnum SET_TRUST_LINE_FLAGS_NO_TRUST_LINE = -2 + xdrFromEnum SET_TRUST_LINE_FLAGS_CANT_REVOKE = -3 + xdrFromEnum SET_TRUST_LINE_FLAGS_INVALID_STATE = -4 + xdrFromEnum SET_TRUST_LINE_FLAGS_LOW_RESERVE = -5 + xdrToEnum 0 = Prelude.return SET_TRUST_LINE_FLAGS_SUCCESS + xdrToEnum (-1) = Prelude.return SET_TRUST_LINE_FLAGS_MALFORMED + xdrToEnum (-2) = Prelude.return SET_TRUST_LINE_FLAGS_NO_TRUST_LINE + xdrToEnum (-3) = Prelude.return SET_TRUST_LINE_FLAGS_CANT_REVOKE + xdrToEnum (-4) = Prelude.return SET_TRUST_LINE_FLAGS_INVALID_STATE + xdrToEnum (-5) = Prelude.return SET_TRUST_LINE_FLAGS_LOW_RESERVE + xdrToEnum _ = Prelude.fail "invalid SetTrustLineFlagsResultCode" + +data SetTrustLineFlagsResult = SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_SUCCESS{} + | SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_MALFORMED{} + | SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_NO_TRUST_LINE{} + | SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_CANT_REVOKE{} + | SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_INVALID_STATE{} + | SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_LOW_RESERVE{} + deriving (Prelude.Eq, Prelude.Show) + +setTrustLineFlagsResult'code :: + SetTrustLineFlagsResult -> SetTrustLineFlagsResultCode +setTrustLineFlagsResult'code = XDR.xdrDiscriminant + +instance XDR.XDR SetTrustLineFlagsResult where + xdrType _ = "SetTrustLineFlagsResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion SetTrustLineFlagsResult where + type XDRDiscriminant SetTrustLineFlagsResult = + SetTrustLineFlagsResultCode + xdrSplitUnion + _x@SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion + _x@SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_MALFORMED{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion + _x@SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_NO_TRUST_LINE{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion + _x@SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_CANT_REVOKE{} + = (-3, Control.Applicative.pure ()) + xdrSplitUnion + _x@SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_INVALID_STATE{} + = (-4, Control.Applicative.pure ()) + xdrSplitUnion + _x@SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_LOW_RESERVE{} + = (-5, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure + SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_SUCCESS + xdrGetUnionArm (-1) + = Control.Applicative.pure + SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_MALFORMED + xdrGetUnionArm (-2) + = Control.Applicative.pure + SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_NO_TRUST_LINE + xdrGetUnionArm (-3) + = Control.Applicative.pure + SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_CANT_REVOKE + xdrGetUnionArm (-4) + = Control.Applicative.pure + SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_INVALID_STATE + xdrGetUnionArm (-5) + = Control.Applicative.pure + SetTrustLineFlagsResult'SET_TRUST_LINE_FLAGS_LOW_RESERVE + xdrGetUnionArm _c + = Prelude.fail "invalid SetTrustLineFlagsResult discriminant" + +data LiquidityPoolDepositResultCode = LIQUIDITY_POOL_DEPOSIT_SUCCESS + | LIQUIDITY_POOL_DEPOSIT_MALFORMED + | LIQUIDITY_POOL_DEPOSIT_NO_TRUST + | LIQUIDITY_POOL_DEPOSIT_NOT_AUTHORIZED + | LIQUIDITY_POOL_DEPOSIT_UNDERFUNDED + | LIQUIDITY_POOL_DEPOSIT_LINE_FULL + | LIQUIDITY_POOL_DEPOSIT_BAD_PRICE + | LIQUIDITY_POOL_DEPOSIT_POOL_FULL + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, + Prelude.Bounded, Prelude.Show) + +instance XDR.XDR LiquidityPoolDepositResultCode where + xdrType _ = "LiquidityPoolDepositResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum LiquidityPoolDepositResultCode where + xdrFromEnum LIQUIDITY_POOL_DEPOSIT_SUCCESS = 0 + xdrFromEnum LIQUIDITY_POOL_DEPOSIT_MALFORMED = -1 + xdrFromEnum LIQUIDITY_POOL_DEPOSIT_NO_TRUST = -2 + xdrFromEnum LIQUIDITY_POOL_DEPOSIT_NOT_AUTHORIZED = -3 + xdrFromEnum LIQUIDITY_POOL_DEPOSIT_UNDERFUNDED = -4 + xdrFromEnum LIQUIDITY_POOL_DEPOSIT_LINE_FULL = -5 + xdrFromEnum LIQUIDITY_POOL_DEPOSIT_BAD_PRICE = -6 + xdrFromEnum LIQUIDITY_POOL_DEPOSIT_POOL_FULL = -7 + xdrToEnum 0 = Prelude.return LIQUIDITY_POOL_DEPOSIT_SUCCESS + xdrToEnum (-1) = Prelude.return LIQUIDITY_POOL_DEPOSIT_MALFORMED + xdrToEnum (-2) = Prelude.return LIQUIDITY_POOL_DEPOSIT_NO_TRUST + xdrToEnum (-3) + = Prelude.return LIQUIDITY_POOL_DEPOSIT_NOT_AUTHORIZED + xdrToEnum (-4) = Prelude.return LIQUIDITY_POOL_DEPOSIT_UNDERFUNDED + xdrToEnum (-5) = Prelude.return LIQUIDITY_POOL_DEPOSIT_LINE_FULL + xdrToEnum (-6) = Prelude.return LIQUIDITY_POOL_DEPOSIT_BAD_PRICE + xdrToEnum (-7) = Prelude.return LIQUIDITY_POOL_DEPOSIT_POOL_FULL + xdrToEnum _ = Prelude.fail "invalid LiquidityPoolDepositResultCode" + +data LiquidityPoolDepositResult = LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_SUCCESS{} + | LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_MALFORMED{} + | LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_NO_TRUST{} + | LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_NOT_AUTHORIZED{} + | LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_UNDERFUNDED{} + | LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_LINE_FULL{} + | LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_BAD_PRICE{} + | LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_POOL_FULL{} + deriving (Prelude.Eq, Prelude.Show) + +liquidityPoolDepositResult'code :: + LiquidityPoolDepositResult -> LiquidityPoolDepositResultCode +liquidityPoolDepositResult'code = XDR.xdrDiscriminant + +instance XDR.XDR LiquidityPoolDepositResult where + xdrType _ = "LiquidityPoolDepositResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion LiquidityPoolDepositResult where + type XDRDiscriminant LiquidityPoolDepositResult = + LiquidityPoolDepositResultCode + xdrSplitUnion + _x@LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion + _x@LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_MALFORMED{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion + _x@LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_NO_TRUST{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion + _x@LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_NOT_AUTHORIZED{} + = (-3, Control.Applicative.pure ()) + xdrSplitUnion + _x@LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_UNDERFUNDED{} + = (-4, Control.Applicative.pure ()) + xdrSplitUnion + _x@LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_LINE_FULL{} + = (-5, Control.Applicative.pure ()) + xdrSplitUnion + _x@LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_BAD_PRICE{} + = (-6, Control.Applicative.pure ()) + xdrSplitUnion + _x@LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_POOL_FULL{} + = (-7, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure + LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_SUCCESS + xdrGetUnionArm (-1) + = Control.Applicative.pure + LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_MALFORMED + xdrGetUnionArm (-2) + = Control.Applicative.pure + LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_NO_TRUST + xdrGetUnionArm (-3) + = Control.Applicative.pure + LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_NOT_AUTHORIZED + xdrGetUnionArm (-4) + = Control.Applicative.pure + LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_UNDERFUNDED + xdrGetUnionArm (-5) + = Control.Applicative.pure + LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_LINE_FULL + xdrGetUnionArm (-6) + = Control.Applicative.pure + LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_BAD_PRICE + xdrGetUnionArm (-7) + = Control.Applicative.pure + LiquidityPoolDepositResult'LIQUIDITY_POOL_DEPOSIT_POOL_FULL + xdrGetUnionArm _c + = Prelude.fail "invalid LiquidityPoolDepositResult discriminant" + +data LiquidityPoolWithdrawResultCode = LIQUIDITY_POOL_WITHDRAW_SUCCESS + | LIQUIDITY_POOL_WITHDRAW_MALFORMED + | LIQUIDITY_POOL_WITHDRAW_NO_TRUST + | LIQUIDITY_POOL_WITHDRAW_UNDERFUNDED + | LIQUIDITY_POOL_WITHDRAW_LINE_FULL + | LIQUIDITY_POOL_WITHDRAW_UNDER_MINIMUM + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, + Prelude.Bounded, Prelude.Show) + +instance XDR.XDR LiquidityPoolWithdrawResultCode where + xdrType _ = "LiquidityPoolWithdrawResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum LiquidityPoolWithdrawResultCode where + xdrFromEnum LIQUIDITY_POOL_WITHDRAW_SUCCESS = 0 + xdrFromEnum LIQUIDITY_POOL_WITHDRAW_MALFORMED = -1 + xdrFromEnum LIQUIDITY_POOL_WITHDRAW_NO_TRUST = -2 + xdrFromEnum LIQUIDITY_POOL_WITHDRAW_UNDERFUNDED = -3 + xdrFromEnum LIQUIDITY_POOL_WITHDRAW_LINE_FULL = -4 + xdrFromEnum LIQUIDITY_POOL_WITHDRAW_UNDER_MINIMUM = -5 + xdrToEnum 0 = Prelude.return LIQUIDITY_POOL_WITHDRAW_SUCCESS + xdrToEnum (-1) = Prelude.return LIQUIDITY_POOL_WITHDRAW_MALFORMED + xdrToEnum (-2) = Prelude.return LIQUIDITY_POOL_WITHDRAW_NO_TRUST + xdrToEnum (-3) = Prelude.return LIQUIDITY_POOL_WITHDRAW_UNDERFUNDED + xdrToEnum (-4) = Prelude.return LIQUIDITY_POOL_WITHDRAW_LINE_FULL + xdrToEnum (-5) + = Prelude.return LIQUIDITY_POOL_WITHDRAW_UNDER_MINIMUM + xdrToEnum _ + = Prelude.fail "invalid LiquidityPoolWithdrawResultCode" + +data LiquidityPoolWithdrawResult = LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_SUCCESS{} + | LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_MALFORMED{} + | LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_NO_TRUST{} + | LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_UNDERFUNDED{} + | LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_LINE_FULL{} + | LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_UNDER_MINIMUM{} + deriving (Prelude.Eq, Prelude.Show) + +liquidityPoolWithdrawResult'code :: + LiquidityPoolWithdrawResult -> LiquidityPoolWithdrawResultCode +liquidityPoolWithdrawResult'code = XDR.xdrDiscriminant + +instance XDR.XDR LiquidityPoolWithdrawResult where + xdrType _ = "LiquidityPoolWithdrawResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion LiquidityPoolWithdrawResult where + type XDRDiscriminant LiquidityPoolWithdrawResult = + LiquidityPoolWithdrawResultCode + xdrSplitUnion + _x@LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion + _x@LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_MALFORMED{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion + _x@LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_NO_TRUST{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion + _x@LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_UNDERFUNDED{} + = (-3, Control.Applicative.pure ()) + xdrSplitUnion + _x@LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_LINE_FULL{} + = (-4, Control.Applicative.pure ()) + xdrSplitUnion + _x@LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_UNDER_MINIMUM{} + = (-5, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure + LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_SUCCESS + xdrGetUnionArm (-1) + = Control.Applicative.pure + LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_MALFORMED + xdrGetUnionArm (-2) + = Control.Applicative.pure + LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_NO_TRUST + xdrGetUnionArm (-3) + = Control.Applicative.pure + LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_UNDERFUNDED + xdrGetUnionArm (-4) + = Control.Applicative.pure + LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_LINE_FULL + xdrGetUnionArm (-5) + = Control.Applicative.pure + LiquidityPoolWithdrawResult'LIQUIDITY_POOL_WITHDRAW_UNDER_MINIMUM + xdrGetUnionArm _c + = Prelude.fail "invalid LiquidityPoolWithdrawResult discriminant" + +data OperationResultCode = OpINNER + | OpBAD_AUTH + | OpNO_ACCOUNT + | OpNOT_SUPPORTED + | OpTOO_MANY_SUBENTRIES + | OpEXCEEDED_WORK_LIMIT + | OpTOO_MANY_SPONSORING + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR OperationResultCode where + xdrType _ = "OperationResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum OperationResultCode where + xdrFromEnum OpINNER = 0 + xdrFromEnum OpBAD_AUTH = -1 + xdrFromEnum OpNO_ACCOUNT = -2 + xdrFromEnum OpNOT_SUPPORTED = -3 + xdrFromEnum OpTOO_MANY_SUBENTRIES = -4 + xdrFromEnum OpEXCEEDED_WORK_LIMIT = -5 + xdrFromEnum OpTOO_MANY_SPONSORING = -6 + xdrToEnum 0 = Prelude.return OpINNER + xdrToEnum (-1) = Prelude.return OpBAD_AUTH + xdrToEnum (-2) = Prelude.return OpNO_ACCOUNT + xdrToEnum (-3) = Prelude.return OpNOT_SUPPORTED + xdrToEnum (-4) = Prelude.return OpTOO_MANY_SUBENTRIES + xdrToEnum (-5) = Prelude.return OpEXCEEDED_WORK_LIMIT + xdrToEnum (-6) = Prelude.return OpTOO_MANY_SPONSORING + xdrToEnum _ = Prelude.fail "invalid OperationResultCode" + +data OperationResultTr = OperationResultTr'CREATE_ACCOUNT{operationResultTr'createAccountResult + :: !CreateAccountResult} + | OperationResultTr'PAYMENT{operationResultTr'paymentResult :: + !PaymentResult} + | OperationResultTr'PATH_PAYMENT_STRICT_RECEIVE{operationResultTr'pathPaymentStrictReceiveResult + :: + !PathPaymentStrictReceiveResult} + | OperationResultTr'MANAGE_SELL_OFFER{operationResultTr'manageSellOfferResult + :: !ManageSellOfferResult} + | OperationResultTr'CREATE_PASSIVE_SELL_OFFER{operationResultTr'createPassiveSellOfferResult + :: !ManageSellOfferResult} + | OperationResultTr'SET_OPTIONS{operationResultTr'setOptionsResult + :: !SetOptionsResult} + | OperationResultTr'CHANGE_TRUST{operationResultTr'changeTrustResult + :: !ChangeTrustResult} + | OperationResultTr'ALLOW_TRUST{operationResultTr'allowTrustResult + :: !AllowTrustResult} + | OperationResultTr'ACCOUNT_MERGE{operationResultTr'accountMergeResult + :: !AccountMergeResult} + | OperationResultTr'INFLATION{operationResultTr'inflationResult :: + !InflationResult} + | OperationResultTr'MANAGE_DATA{operationResultTr'manageDataResult + :: !ManageDataResult} + | OperationResultTr'BUMP_SEQUENCE{operationResultTr'bumpSeqResult + :: !BumpSequenceResult} + | OperationResultTr'MANAGE_BUY_OFFER{operationResultTr'manageBuyOfferResult + :: !ManageBuyOfferResult} + | OperationResultTr'PATH_PAYMENT_STRICT_SEND{operationResultTr'pathPaymentStrictSendResult + :: !PathPaymentStrictSendResult} + | OperationResultTr'CREATE_CLAIMABLE_BALANCE{operationResultTr'createClaimableBalanceResult + :: + !CreateClaimableBalanceResult} + | OperationResultTr'CLAIM_CLAIMABLE_BALANCE{operationResultTr'claimClaimableBalanceResult + :: !ClaimClaimableBalanceResult} + | OperationResultTr'BEGIN_SPONSORING_FUTURE_RESERVES{operationResultTr'beginSponsoringFutureReservesResult + :: + !BeginSponsoringFutureReservesResult} + | OperationResultTr'END_SPONSORING_FUTURE_RESERVES{operationResultTr'endSponsoringFutureReservesResult + :: + !EndSponsoringFutureReservesResult} + | OperationResultTr'REVOKE_SPONSORSHIP{operationResultTr'revokeSponsorshipResult + :: !RevokeSponsorshipResult} + | OperationResultTr'CLAWBACK{operationResultTr'clawbackResult :: + !ClawbackResult} + | OperationResultTr'CLAWBACK_CLAIMABLE_BALANCE{operationResultTr'clawbackClaimableBalanceResult + :: + !ClawbackClaimableBalanceResult} + | OperationResultTr'SET_TRUST_LINE_FLAGS{operationResultTr'setTrustLineFlagsResult + :: !SetTrustLineFlagsResult} + | OperationResultTr'LIQUIDITY_POOL_DEPOSIT{operationResultTr'liquidityPoolDepositResult + :: !LiquidityPoolDepositResult} + | OperationResultTr'LIQUIDITY_POOL_WITHDRAW{operationResultTr'liquidityPoolWithdrawResult + :: !LiquidityPoolWithdrawResult} + deriving (Prelude.Eq, Prelude.Show) + +operationResultTr'type :: OperationResultTr -> OperationType +operationResultTr'type = XDR.xdrDiscriminant + +instance XDR.XDR OperationResultTr where + xdrType _ = "OperationResultTr" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion OperationResultTr where + type XDRDiscriminant OperationResultTr = OperationType + xdrSplitUnion _x@OperationResultTr'CREATE_ACCOUNT{} + = (0, XDR.xdrPut (operationResultTr'createAccountResult _x)) + xdrSplitUnion _x@OperationResultTr'PAYMENT{} + = (1, XDR.xdrPut (operationResultTr'paymentResult _x)) + xdrSplitUnion _x@OperationResultTr'PATH_PAYMENT_STRICT_RECEIVE{} + = (2, + XDR.xdrPut (operationResultTr'pathPaymentStrictReceiveResult _x)) + xdrSplitUnion _x@OperationResultTr'MANAGE_SELL_OFFER{} + = (3, XDR.xdrPut (operationResultTr'manageSellOfferResult _x)) + xdrSplitUnion _x@OperationResultTr'CREATE_PASSIVE_SELL_OFFER{} + = (4, + XDR.xdrPut (operationResultTr'createPassiveSellOfferResult _x)) + xdrSplitUnion _x@OperationResultTr'SET_OPTIONS{} + = (5, XDR.xdrPut (operationResultTr'setOptionsResult _x)) + xdrSplitUnion _x@OperationResultTr'CHANGE_TRUST{} + = (6, XDR.xdrPut (operationResultTr'changeTrustResult _x)) + xdrSplitUnion _x@OperationResultTr'ALLOW_TRUST{} + = (7, XDR.xdrPut (operationResultTr'allowTrustResult _x)) + xdrSplitUnion _x@OperationResultTr'ACCOUNT_MERGE{} + = (8, XDR.xdrPut (operationResultTr'accountMergeResult _x)) + xdrSplitUnion _x@OperationResultTr'INFLATION{} + = (9, XDR.xdrPut (operationResultTr'inflationResult _x)) + xdrSplitUnion _x@OperationResultTr'MANAGE_DATA{} + = (10, XDR.xdrPut (operationResultTr'manageDataResult _x)) + xdrSplitUnion _x@OperationResultTr'BUMP_SEQUENCE{} + = (11, XDR.xdrPut (operationResultTr'bumpSeqResult _x)) + xdrSplitUnion _x@OperationResultTr'MANAGE_BUY_OFFER{} + = (12, XDR.xdrPut (operationResultTr'manageBuyOfferResult _x)) + xdrSplitUnion _x@OperationResultTr'PATH_PAYMENT_STRICT_SEND{} + = (13, + XDR.xdrPut (operationResultTr'pathPaymentStrictSendResult _x)) + xdrSplitUnion _x@OperationResultTr'CREATE_CLAIMABLE_BALANCE{} + = (14, + XDR.xdrPut (operationResultTr'createClaimableBalanceResult _x)) + xdrSplitUnion _x@OperationResultTr'CLAIM_CLAIMABLE_BALANCE{} + = (15, + XDR.xdrPut (operationResultTr'claimClaimableBalanceResult _x)) + xdrSplitUnion + _x@OperationResultTr'BEGIN_SPONSORING_FUTURE_RESERVES{} + = (16, + XDR.xdrPut + (operationResultTr'beginSponsoringFutureReservesResult _x)) + xdrSplitUnion _x@OperationResultTr'END_SPONSORING_FUTURE_RESERVES{} + = (17, + XDR.xdrPut + (operationResultTr'endSponsoringFutureReservesResult _x)) + xdrSplitUnion _x@OperationResultTr'REVOKE_SPONSORSHIP{} + = (18, XDR.xdrPut (operationResultTr'revokeSponsorshipResult _x)) + xdrSplitUnion _x@OperationResultTr'CLAWBACK{} + = (19, XDR.xdrPut (operationResultTr'clawbackResult _x)) + xdrSplitUnion _x@OperationResultTr'CLAWBACK_CLAIMABLE_BALANCE{} + = (20, + XDR.xdrPut (operationResultTr'clawbackClaimableBalanceResult _x)) + xdrSplitUnion _x@OperationResultTr'SET_TRUST_LINE_FLAGS{} + = (21, XDR.xdrPut (operationResultTr'setTrustLineFlagsResult _x)) + xdrSplitUnion _x@OperationResultTr'LIQUIDITY_POOL_DEPOSIT{} + = (22, + XDR.xdrPut (operationResultTr'liquidityPoolDepositResult _x)) + xdrSplitUnion _x@OperationResultTr'LIQUIDITY_POOL_WITHDRAW{} + = (23, + XDR.xdrPut (operationResultTr'liquidityPoolWithdrawResult _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure OperationResultTr'CREATE_ACCOUNT + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 1 + = Control.Applicative.pure OperationResultTr'PAYMENT + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 2 + = Control.Applicative.pure + OperationResultTr'PATH_PAYMENT_STRICT_RECEIVE + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 3 + = Control.Applicative.pure OperationResultTr'MANAGE_SELL_OFFER + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 4 + = Control.Applicative.pure + OperationResultTr'CREATE_PASSIVE_SELL_OFFER + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 5 + = Control.Applicative.pure OperationResultTr'SET_OPTIONS + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 6 + = Control.Applicative.pure OperationResultTr'CHANGE_TRUST + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 7 + = Control.Applicative.pure OperationResultTr'ALLOW_TRUST + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 8 + = Control.Applicative.pure OperationResultTr'ACCOUNT_MERGE + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 9 + = Control.Applicative.pure OperationResultTr'INFLATION + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 10 + = Control.Applicative.pure OperationResultTr'MANAGE_DATA + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 11 + = Control.Applicative.pure OperationResultTr'BUMP_SEQUENCE + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 12 + = Control.Applicative.pure OperationResultTr'MANAGE_BUY_OFFER + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 13 + = Control.Applicative.pure + OperationResultTr'PATH_PAYMENT_STRICT_SEND + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 14 + = Control.Applicative.pure + OperationResultTr'CREATE_CLAIMABLE_BALANCE + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 15 + = Control.Applicative.pure + OperationResultTr'CLAIM_CLAIMABLE_BALANCE + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 16 + = Control.Applicative.pure + OperationResultTr'BEGIN_SPONSORING_FUTURE_RESERVES + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 17 + = Control.Applicative.pure + OperationResultTr'END_SPONSORING_FUTURE_RESERVES + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 18 + = Control.Applicative.pure OperationResultTr'REVOKE_SPONSORSHIP + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 19 + = Control.Applicative.pure OperationResultTr'CLAWBACK + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 20 + = Control.Applicative.pure + OperationResultTr'CLAWBACK_CLAIMABLE_BALANCE + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 21 + = Control.Applicative.pure OperationResultTr'SET_TRUST_LINE_FLAGS + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 22 + = Control.Applicative.pure OperationResultTr'LIQUIDITY_POOL_DEPOSIT + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 23 + = Control.Applicative.pure + OperationResultTr'LIQUIDITY_POOL_WITHDRAW + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = Prelude.fail "invalid OperationResultTr discriminant" + +data OperationResult = OperationResult'OpINNER{operationResult'tr + :: !OperationResultTr} + | OperationResult'OpBAD_AUTH{} + | OperationResult'OpNO_ACCOUNT{} + | OperationResult'OpNOT_SUPPORTED{} + | OperationResult'OpTOO_MANY_SUBENTRIES{} + | OperationResult'OpEXCEEDED_WORK_LIMIT{} + | OperationResult'OpTOO_MANY_SPONSORING{} + deriving (Prelude.Eq, Prelude.Show) + +operationResult'code :: OperationResult -> OperationResultCode +operationResult'code = XDR.xdrDiscriminant + +instance XDR.XDR OperationResult where + xdrType _ = "OperationResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion OperationResult where + type XDRDiscriminant OperationResult = OperationResultCode + xdrSplitUnion _x@OperationResult'OpINNER{} + = (0, XDR.xdrPut (operationResult'tr _x)) + xdrSplitUnion _x@OperationResult'OpBAD_AUTH{} + = (-1, Control.Applicative.pure ()) + xdrSplitUnion _x@OperationResult'OpNO_ACCOUNT{} + = (-2, Control.Applicative.pure ()) + xdrSplitUnion _x@OperationResult'OpNOT_SUPPORTED{} + = (-3, Control.Applicative.pure ()) + xdrSplitUnion _x@OperationResult'OpTOO_MANY_SUBENTRIES{} + = (-4, Control.Applicative.pure ()) + xdrSplitUnion _x@OperationResult'OpEXCEEDED_WORK_LIMIT{} + = (-5, Control.Applicative.pure ()) + xdrSplitUnion _x@OperationResult'OpTOO_MANY_SPONSORING{} + = (-6, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure OperationResult'OpINNER + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm (-1) + = Control.Applicative.pure OperationResult'OpBAD_AUTH + xdrGetUnionArm (-2) + = Control.Applicative.pure OperationResult'OpNO_ACCOUNT + xdrGetUnionArm (-3) + = Control.Applicative.pure OperationResult'OpNOT_SUPPORTED + xdrGetUnionArm (-4) + = Control.Applicative.pure OperationResult'OpTOO_MANY_SUBENTRIES + xdrGetUnionArm (-5) + = Control.Applicative.pure OperationResult'OpEXCEEDED_WORK_LIMIT + xdrGetUnionArm (-6) + = Control.Applicative.pure OperationResult'OpTOO_MANY_SPONSORING + xdrGetUnionArm _c + = Prelude.fail "invalid OperationResult discriminant" + +data TransactionResultCode = TRANSACTION_RESULT_SUCCESS + | TRANSACTION_RESULT_FAILED + | TRANSACTION_RESULT_TOO_EARLY + | TRANSACTION_RESULT_TOO_LATE + | TRANSACTION_RESULT_MISSING_OPERATION + | TRANSACTION_RESULT_BAD_SEQ + | TRANSACTION_RESULT_BAD_AUTH + | TRANSACTION_RESULT_INSUFFICIENT_BALANCE + | TRANSACTION_RESULT_NO_ACCOUNT + | TRANSACTION_RESULT_INSUFFICIENT_FEE + | TRANSACTION_RESULT_BAD_AUTH_EXTRA + | TRANSACTION_RESULT_INTERNAL_ERROR + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR TransactionResultCode where + xdrType _ = "TransactionResultCode" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum TransactionResultCode where + xdrFromEnum TRANSACTION_RESULT_SUCCESS = 0 + xdrFromEnum TRANSACTION_RESULT_FAILED = -1 + xdrFromEnum TRANSACTION_RESULT_TOO_EARLY = -2 + xdrFromEnum TRANSACTION_RESULT_TOO_LATE = -3 + xdrFromEnum TRANSACTION_RESULT_MISSING_OPERATION = -4 + xdrFromEnum TRANSACTION_RESULT_BAD_SEQ = -5 + xdrFromEnum TRANSACTION_RESULT_BAD_AUTH = -6 + xdrFromEnum TRANSACTION_RESULT_INSUFFICIENT_BALANCE = -7 + xdrFromEnum TRANSACTION_RESULT_NO_ACCOUNT = -8 + xdrFromEnum TRANSACTION_RESULT_INSUFFICIENT_FEE = -9 + xdrFromEnum TRANSACTION_RESULT_BAD_AUTH_EXTRA = -10 + xdrFromEnum TRANSACTION_RESULT_INTERNAL_ERROR = -11 + xdrToEnum 0 = Prelude.return TRANSACTION_RESULT_SUCCESS + xdrToEnum (-1) = Prelude.return TRANSACTION_RESULT_FAILED + xdrToEnum (-2) = Prelude.return TRANSACTION_RESULT_TOO_EARLY + xdrToEnum (-3) = Prelude.return TRANSACTION_RESULT_TOO_LATE + xdrToEnum (-4) + = Prelude.return TRANSACTION_RESULT_MISSING_OPERATION + xdrToEnum (-5) = Prelude.return TRANSACTION_RESULT_BAD_SEQ + xdrToEnum (-6) = Prelude.return TRANSACTION_RESULT_BAD_AUTH + xdrToEnum (-7) + = Prelude.return TRANSACTION_RESULT_INSUFFICIENT_BALANCE + xdrToEnum (-8) = Prelude.return TRANSACTION_RESULT_NO_ACCOUNT + xdrToEnum (-9) = Prelude.return TRANSACTION_RESULT_INSUFFICIENT_FEE + xdrToEnum (-10) = Prelude.return TRANSACTION_RESULT_BAD_AUTH_EXTRA + xdrToEnum (-11) = Prelude.return TRANSACTION_RESULT_INTERNAL_ERROR + xdrToEnum _ = Prelude.fail "invalid TransactionResultCode" + +data TransactionResultResult = TransactionResultResult'TRANSACTION_RESULT_SUCCESS{transactionResultResult'results + :: + !(XDR.Array + 4294967295 + OperationResult)} + | TransactionResultResult'TRANSACTION_RESULT_FAILED{transactionResultResult'results + :: + !(XDR.Array + 4294967295 + OperationResult)} + | TransactionResultResult'default{transactionResultResult'code' :: + !TransactionResultCode} + deriving (Prelude.Eq, Prelude.Show) + +transactionResultResult'code :: + TransactionResultResult -> TransactionResultCode +transactionResultResult'code = XDR.xdrDiscriminant + +instance XDR.XDR TransactionResultResult where + xdrType _ = "TransactionResultResult" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion TransactionResultResult where + type XDRDiscriminant TransactionResultResult = + TransactionResultCode + xdrSplitUnion + _x@TransactionResultResult'TRANSACTION_RESULT_SUCCESS{} + = (0, XDR.xdrPut (transactionResultResult'results _x)) + xdrSplitUnion + _x@TransactionResultResult'TRANSACTION_RESULT_FAILED{} + = (-1, XDR.xdrPut (transactionResultResult'results _x)) + xdrSplitUnion + _x@TransactionResultResult'default{transactionResultResult'code' = + d} + = (XDR.xdrFromEnum d, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure + TransactionResultResult'TRANSACTION_RESULT_SUCCESS + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm (-1) + = Control.Applicative.pure + TransactionResultResult'TRANSACTION_RESULT_FAILED + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = TransactionResultResult'default Control.Applicative.<$> + XDR.xdrToEnum _c + +data TransactionResult = TransactionResult{transactionResult'feeCharged + :: !Int64, + transactionResult'result :: !TransactionResultResult} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR TransactionResult where + xdrType _ = "TransactionResult" + xdrPut _x + = XDR.xdrPut (transactionResult'feeCharged _x) + Control.Applicative.*> XDR.xdrPut (transactionResult'result _x) + xdrGet + = Control.Applicative.pure TransactionResult + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet diff --git a/bundled/Stellar/Simple.hs b/bundled/Stellar/Simple.hs new file mode 100644 index 0000000..b8b8dc8 --- /dev/null +++ b/bundled/Stellar/Simple.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} + +module Stellar.Simple where + +-- prelude +import Prelude hiding (id) +import Prelude qualified + +-- global +import Control.Exception (SomeException (SomeException), catchJust, throwIO) +import Crypto.Sign.Ed25519 qualified as Ed25519 +import Data.ByteString.Base64 qualified as Base64 +import Data.Foldable (toList) +import Data.Int (Int32, Int64) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Monoid (Endo (Endo), appEndo) +import Data.Ratio (Ratio, denominator, numerator) +import Data.Sequence (Seq, (|>)) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding (encodeUtf8, decodeUtf8', encodeUtf8) +import Data.Typeable (cast) +import Data.Word (Word32, Word8) +import GHC.Stack (HasCallStack) +import Text.Read (readEither, readMaybe) + +-- stellar-sdk +import Network.ONCRPC.XDR (XDR, xdrSerialize) +import Network.ONCRPC.XDR qualified as XDR +import Network.Stellar.Keypair qualified as StellarKey +import Network.Stellar.Network (Network, publicNetwork) +import Network.Stellar.Signature qualified as StellarSignature +import Network.Stellar.TransactionXdr (Uint256) +import Network.Stellar.TransactionXdr qualified as XDR + +-- component +import Stellar.Simple.Types (Asset (..), DecoratedSignature (..), Memo (..)) + +identity :: a -> a +identity = Prelude.id + +-- | Make asset from the canonical pair of code and issuer +mkAsset :: Text -> Text -> Asset +mkAsset code issuer = Asset{code, issuer = Just issuer} + +data Guess a = Already a | Guess + deriving (Show) + +signWithSecret :: + HasCallStack => + -- | "S..." textual secret key + Text -> + XDR.TransactionEnvelope -> + XDR.TransactionEnvelope +signWithSecret secret tx = + either (error . show) identity $ + StellarSignature.signTx publicNetwork tx [StellarKey.fromPrivateKey' secret] + +xdrSerializeBase64T :: XDR a => a -> Text +xdrSerializeBase64T = decodeUtf8Throw . Base64.encode . xdrSerialize + +decodeUtf8Throw = either (error . show) identity . decodeUtf8' diff --git a/bundled/Stellar/Simple/Types.hs b/bundled/Stellar/Simple/Types.hs new file mode 100644 index 0000000..3c04c6b --- /dev/null +++ b/bundled/Stellar/Simple/Types.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Stellar.Simple.Types where + +-- global +import Data.ByteString (ByteString) +import Data.ByteString.Base64 qualified as Base64 +import Data.Scientific (Scientific) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Time (UTCTime) +import GHC.Generics (Generic) +import Network.Stellar.TransactionXdr qualified as XDR + +newtype Shown a = Shown String + deriving newtype (Eq) + +instance Show (Shown a) where + show (Shown s) = s + +shown :: Show a => a -> Shown a +shown = Shown . show + +data Asset = Asset{issuer :: Maybe Text, code :: Text} + deriving (Eq, Generic, Ord, Read, Show) + +-- | Representation is "XLM" or "{code}:{issuer}" +assetToText :: Asset -> Text +assetToText Asset{code, issuer} = code <> maybe "" (":" <>) issuer + +assetFromText :: Text -> Asset +assetFromText t + | Text.null _issuer = Asset{code = t, issuer = Nothing} + | otherwise = Asset{code, issuer = Just issuer} + where + (code, _issuer) = Text.break (== ':') t + issuer = Text.drop 1 _issuer + +data Memo = MemoNone | MemoText Text | MemoOther (Shown XDR.Memo) + deriving (Eq, Show) + +data PaymentType = DirectPayment | PathPayment + deriving (Generic, Read, Show) + +data DecoratedSignature = DecoratedSignature{hint, signature :: ByteString} + deriving Show diff --git a/bundled/Utils.hs b/bundled/Utils.hs new file mode 100644 index 0000000..7a8dd05 --- /dev/null +++ b/bundled/Utils.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Utils + ( roundTo + , i2d + , maxExpt + , magnitude + ) where + +import GHC.Base (Int(I#), Char(C#), chr#, ord#, (+#)) + +import qualified Data.Primitive.Array as Primitive +import Control.Monad.ST (runST) + +import Data.Bits (unsafeShiftR) + +roundTo :: Int -> [Int] -> (Int, [Int]) +roundTo d is = + case f d True is of + x@(0,_) -> x + (1,xs) -> (1, 1:xs) + _ -> error "roundTo: bad Value" + where + base = 10 + + b2 = base `quot` 2 + + f n _ [] = (0, replicate n 0) + f 0 e (x:xs) | x == b2 && e && all (== 0) xs = (0, []) -- Round to even when at exactly half the base + | otherwise = (if x >= b2 then 1 else 0, []) + f n _ (i:xs) + | i' == base = (1,0:ds) + | otherwise = (0,i':ds) + where + (c,ds) = f (n-1) (even i) xs + i' = c + i + +-- | Unsafe conversion for decimal digits. +{-# INLINE i2d #-} +i2d :: Int -> Char +i2d (I# i#) = C# (chr# (ord# '0'# +# i# )) + +---------------------------------------------------------------------- +-- Exponentiation with a cache for the most common numbers. +---------------------------------------------------------------------- + +-- | The same limit as in GHC.Float. +maxExpt :: Int +maxExpt = 324 + +expts10 :: Primitive.Array Integer +expts10 = runST $ do + ma <- Primitive.newArray maxExpt uninitialised + Primitive.writeArray ma 0 1 + Primitive.writeArray ma 1 10 + let go !ix + | ix == maxExpt = Primitive.unsafeFreezeArray ma + | otherwise = do + Primitive.writeArray ma ix xx + Primitive.writeArray ma (ix+1) (10*xx) + go (ix+2) + where + xx = x * x + x = Primitive.indexArray expts10 half + !half = ix `unsafeShiftR` 1 + go 2 + +uninitialised :: error +uninitialised = error "Data.Scientific: uninitialised element" + +-- | @magnitude e == 10 ^ e@ +magnitude :: Num a => Int -> a +magnitude e | e < maxExpt = cachedPow10 e + | otherwise = cachedPow10 hi * 10 ^ (e - hi) + where + cachedPow10 = fromInteger . Primitive.indexArray expts10 + + hi = maxExpt - 1 diff --git a/bundled/cbits/ref10/crypto_verify.c b/bundled/cbits/ref10/crypto_verify.c new file mode 100644 index 0000000..8bdb455 --- /dev/null +++ b/bundled/cbits/ref10/crypto_verify.c @@ -0,0 +1,67 @@ +#include "crypto_verify.h" + +#define VERIFY_F(i) differentbits |= x[i] ^ y[i]; + +static inline +int crypto_verify_16(const unsigned char *x,const unsigned char *y) +{ + unsigned int differentbits = 0; + VERIFY_F(0) + VERIFY_F(1) + VERIFY_F(2) + VERIFY_F(3) + VERIFY_F(4) + VERIFY_F(5) + VERIFY_F(6) + VERIFY_F(7) + VERIFY_F(8) + VERIFY_F(9) + VERIFY_F(10) + VERIFY_F(11) + VERIFY_F(12) + VERIFY_F(13) + VERIFY_F(14) + VERIFY_F(15) + return (1 & ((differentbits - 1) >> 8)) - 1; +} + +static inline +int crypto_verify_32(const unsigned char *x,const unsigned char *y) +{ + unsigned int differentbits = 0; + VERIFY_F(0) + VERIFY_F(1) + VERIFY_F(2) + VERIFY_F(3) + VERIFY_F(4) + VERIFY_F(5) + VERIFY_F(6) + VERIFY_F(7) + VERIFY_F(8) + VERIFY_F(9) + VERIFY_F(10) + VERIFY_F(11) + VERIFY_F(12) + VERIFY_F(13) + VERIFY_F(14) + VERIFY_F(15) + VERIFY_F(16) + VERIFY_F(17) + VERIFY_F(18) + VERIFY_F(19) + VERIFY_F(20) + VERIFY_F(21) + VERIFY_F(22) + VERIFY_F(23) + VERIFY_F(24) + VERIFY_F(25) + VERIFY_F(26) + VERIFY_F(27) + VERIFY_F(28) + VERIFY_F(29) + VERIFY_F(30) + VERIFY_F(31) + return (1 & ((differentbits - 1) >> 8)) - 1; +} + +#undef VERIFY_F diff --git a/bundled/cbits/ref10/ed25519.c b/bundled/cbits/ref10/ed25519.c new file mode 100644 index 0000000..1942b5c --- /dev/null +++ b/bundled/cbits/ref10/ed25519.c @@ -0,0 +1,42 @@ +#include "sha512.c" +#include "fe_tobytes.c" +#include "fe_copy.c" +#include "fe_1.c" +#include "ge_tobytes.c" +#include "sign.c" +#include "fe_sq2.c" +#include "fe_cmov.c" +#include "ge_p1p1_to_p3.c" +#include "ge_p3_dbl.c" +#include "fe_mul.c" +#include "ge_p3_to_cached.c" +#include "fe_pow22523.c" +#include "ge_add.c" +#include "ge_sub.c" +#include "fe_add.c" +#include "ge_p2_0.c" +#include "ge_p3_to_p2.c" +#include "fe_invert.c" +#include "open.c" +#include "ge_msub.c" +#include "fe_0.c" +#include "fe_sub.c" +#include "fe_isnonzero.c" +#include "fe_isnegative.c" +#include "fe_neg.c" +#include "ge_frombytes.c" +#include "ge_p3_tobytes.c" +#include "ge_double_scalarmult.c" +#include "ge_p1p1_to_p2.c" +#include "fe_sq.c" +#include "ge_p3_0.c" +#include "ge_precomp_0.c" +#include "ge_scalarmult_base.c" +#include "sc_reduce.c" +#include "keypair.c" +#include "fe_frombytes.c" +#include "sc_muladd.c" +#include "ge_madd.c" +#include "ge_p2_dbl.c" +#include "crypto_verify.c" +#include "randombytes.c" diff --git a/bundled/cbits/ref10/fe_0.c b/bundled/cbits/ref10/fe_0.c new file mode 100644 index 0000000..5d968a5 --- /dev/null +++ b/bundled/cbits/ref10/fe_0.c @@ -0,0 +1,19 @@ +#include "fe.h" + +/* +h = 0 +*/ + +static inline void fe_0(fe h) +{ + h[0] = 0; + h[1] = 0; + h[2] = 0; + h[3] = 0; + h[4] = 0; + h[5] = 0; + h[6] = 0; + h[7] = 0; + h[8] = 0; + h[9] = 0; +} diff --git a/bundled/cbits/ref10/fe_1.c b/bundled/cbits/ref10/fe_1.c new file mode 100644 index 0000000..473073f --- /dev/null +++ b/bundled/cbits/ref10/fe_1.c @@ -0,0 +1,19 @@ +#include "fe.h" + +/* +h = 1 +*/ + +static inline void fe_1(fe h) +{ + h[0] = 1; + h[1] = 0; + h[2] = 0; + h[3] = 0; + h[4] = 0; + h[5] = 0; + h[6] = 0; + h[7] = 0; + h[8] = 0; + h[9] = 0; +} diff --git a/bundled/cbits/ref10/fe_add.c b/bundled/cbits/ref10/fe_add.c new file mode 100644 index 0000000..a3772b4 --- /dev/null +++ b/bundled/cbits/ref10/fe_add.c @@ -0,0 +1,57 @@ +#include "fe.h" + +/* +h = f + g +Can overlap h with f or g. + +Preconditions: + |f| bounded by 1.1*2^25,1.1*2^24,1.1*2^25,1.1*2^24,etc. + |g| bounded by 1.1*2^25,1.1*2^24,1.1*2^25,1.1*2^24,etc. + +Postconditions: + |h| bounded by 1.1*2^26,1.1*2^25,1.1*2^26,1.1*2^25,etc. +*/ + +static inline void fe_add(fe h,const fe f,const fe g) +{ + crypto_int32 f0 = f[0]; + crypto_int32 f1 = f[1]; + crypto_int32 f2 = f[2]; + crypto_int32 f3 = f[3]; + crypto_int32 f4 = f[4]; + crypto_int32 f5 = f[5]; + crypto_int32 f6 = f[6]; + crypto_int32 f7 = f[7]; + crypto_int32 f8 = f[8]; + crypto_int32 f9 = f[9]; + crypto_int32 g0 = g[0]; + crypto_int32 g1 = g[1]; + crypto_int32 g2 = g[2]; + crypto_int32 g3 = g[3]; + crypto_int32 g4 = g[4]; + crypto_int32 g5 = g[5]; + crypto_int32 g6 = g[6]; + crypto_int32 g7 = g[7]; + crypto_int32 g8 = g[8]; + crypto_int32 g9 = g[9]; + crypto_int32 h0 = f0 + g0; + crypto_int32 h1 = f1 + g1; + crypto_int32 h2 = f2 + g2; + crypto_int32 h3 = f3 + g3; + crypto_int32 h4 = f4 + g4; + crypto_int32 h5 = f5 + g5; + crypto_int32 h6 = f6 + g6; + crypto_int32 h7 = f7 + g7; + crypto_int32 h8 = f8 + g8; + crypto_int32 h9 = f9 + g9; + h[0] = h0; + h[1] = h1; + h[2] = h2; + h[3] = h3; + h[4] = h4; + h[5] = h5; + h[6] = h6; + h[7] = h7; + h[8] = h8; + h[9] = h9; +} diff --git a/bundled/cbits/ref10/fe_cmov.c b/bundled/cbits/ref10/fe_cmov.c new file mode 100644 index 0000000..3650cfc --- /dev/null +++ b/bundled/cbits/ref10/fe_cmov.c @@ -0,0 +1,63 @@ +#include "fe.h" + +/* +Replace (f,g) with (g,g) if b == 1; +replace (f,g) with (f,g) if b == 0. + +Preconditions: b in {0,1}. +*/ + +static inline void fe_cmov(fe f,const fe g,unsigned int b) +{ + crypto_int32 f0 = f[0]; + crypto_int32 f1 = f[1]; + crypto_int32 f2 = f[2]; + crypto_int32 f3 = f[3]; + crypto_int32 f4 = f[4]; + crypto_int32 f5 = f[5]; + crypto_int32 f6 = f[6]; + crypto_int32 f7 = f[7]; + crypto_int32 f8 = f[8]; + crypto_int32 f9 = f[9]; + crypto_int32 g0 = g[0]; + crypto_int32 g1 = g[1]; + crypto_int32 g2 = g[2]; + crypto_int32 g3 = g[3]; + crypto_int32 g4 = g[4]; + crypto_int32 g5 = g[5]; + crypto_int32 g6 = g[6]; + crypto_int32 g7 = g[7]; + crypto_int32 g8 = g[8]; + crypto_int32 g9 = g[9]; + crypto_int32 x0 = f0 ^ g0; + crypto_int32 x1 = f1 ^ g1; + crypto_int32 x2 = f2 ^ g2; + crypto_int32 x3 = f3 ^ g3; + crypto_int32 x4 = f4 ^ g4; + crypto_int32 x5 = f5 ^ g5; + crypto_int32 x6 = f6 ^ g6; + crypto_int32 x7 = f7 ^ g7; + crypto_int32 x8 = f8 ^ g8; + crypto_int32 x9 = f9 ^ g9; + b = -b; + x0 &= b; + x1 &= b; + x2 &= b; + x3 &= b; + x4 &= b; + x5 &= b; + x6 &= b; + x7 &= b; + x8 &= b; + x9 &= b; + f[0] = f0 ^ x0; + f[1] = f1 ^ x1; + f[2] = f2 ^ x2; + f[3] = f3 ^ x3; + f[4] = f4 ^ x4; + f[5] = f5 ^ x5; + f[6] = f6 ^ x6; + f[7] = f7 ^ x7; + f[8] = f8 ^ x8; + f[9] = f9 ^ x9; +} diff --git a/bundled/cbits/ref10/fe_copy.c b/bundled/cbits/ref10/fe_copy.c new file mode 100644 index 0000000..9e1de7f --- /dev/null +++ b/bundled/cbits/ref10/fe_copy.c @@ -0,0 +1,29 @@ +#include "fe.h" + +/* +h = f +*/ + +static inline void fe_copy(fe h,const fe f) +{ + crypto_int32 f0 = f[0]; + crypto_int32 f1 = f[1]; + crypto_int32 f2 = f[2]; + crypto_int32 f3 = f[3]; + crypto_int32 f4 = f[4]; + crypto_int32 f5 = f[5]; + crypto_int32 f6 = f[6]; + crypto_int32 f7 = f[7]; + crypto_int32 f8 = f[8]; + crypto_int32 f9 = f[9]; + h[0] = f0; + h[1] = f1; + h[2] = f2; + h[3] = f3; + h[4] = f4; + h[5] = f5; + h[6] = f6; + h[7] = f7; + h[8] = f8; + h[9] = f9; +} diff --git a/bundled/cbits/ref10/fe_frombytes.c b/bundled/cbits/ref10/fe_frombytes.c new file mode 100644 index 0000000..1e50457 --- /dev/null +++ b/bundled/cbits/ref10/fe_frombytes.c @@ -0,0 +1,55 @@ +#include "fe.h" +#include "load.h" +#include "crypto_int64.h" +#include "crypto_uint64.h" + +/* +Ignores top bit of h. +*/ + +static inline void fe_frombytes(fe h,const unsigned char *s) +{ + crypto_int64 h0 = load_4(s); + crypto_int64 h1 = load_3(s + 4) << 6; + crypto_int64 h2 = load_3(s + 7) << 5; + crypto_int64 h3 = load_3(s + 10) << 3; + crypto_int64 h4 = load_3(s + 13) << 2; + crypto_int64 h5 = load_4(s + 16); + crypto_int64 h6 = load_3(s + 20) << 7; + crypto_int64 h7 = load_3(s + 23) << 5; + crypto_int64 h8 = load_3(s + 26) << 4; + crypto_int64 h9 = (load_3(s + 29) & 8388607) << 2; + crypto_int64 carry0; + crypto_int64 carry1; + crypto_int64 carry2; + crypto_int64 carry3; + crypto_int64 carry4; + crypto_int64 carry5; + crypto_int64 carry6; + crypto_int64 carry7; + crypto_int64 carry8; + crypto_int64 carry9; + + carry9 = (h9 + (crypto_int64) (1<<24)) >> 25; h0 += carry9 * 19; h9 -= carry9 << 25; + carry1 = (h1 + (crypto_int64) (1<<24)) >> 25; h2 += carry1; h1 -= carry1 << 25; + carry3 = (h3 + (crypto_int64) (1<<24)) >> 25; h4 += carry3; h3 -= carry3 << 25; + carry5 = (h5 + (crypto_int64) (1<<24)) >> 25; h6 += carry5; h5 -= carry5 << 25; + carry7 = (h7 + (crypto_int64) (1<<24)) >> 25; h8 += carry7; h7 -= carry7 << 25; + + carry0 = (h0 + (crypto_int64) (1<<25)) >> 26; h1 += carry0; h0 -= carry0 << 26; + carry2 = (h2 + (crypto_int64) (1<<25)) >> 26; h3 += carry2; h2 -= carry2 << 26; + carry4 = (h4 + (crypto_int64) (1<<25)) >> 26; h5 += carry4; h4 -= carry4 << 26; + carry6 = (h6 + (crypto_int64) (1<<25)) >> 26; h7 += carry6; h6 -= carry6 << 26; + carry8 = (h8 + (crypto_int64) (1<<25)) >> 26; h9 += carry8; h8 -= carry8 << 26; + + h[0] = h0; + h[1] = h1; + h[2] = h2; + h[3] = h3; + h[4] = h4; + h[5] = h5; + h[6] = h6; + h[7] = h7; + h[8] = h8; + h[9] = h9; +} diff --git a/bundled/cbits/ref10/fe_invert.c b/bundled/cbits/ref10/fe_invert.c new file mode 100644 index 0000000..bcfdb8f --- /dev/null +++ b/bundled/cbits/ref10/fe_invert.c @@ -0,0 +1,14 @@ +#include "fe.h" + +void fe_invert(fe out,const fe z) +{ + fe t0; + fe t1; + fe t2; + fe t3; + int i; + +#include "pow225521.h" + + return; +} diff --git a/bundled/cbits/ref10/fe_isnegative.c b/bundled/cbits/ref10/fe_isnegative.c new file mode 100644 index 0000000..df2ef41 --- /dev/null +++ b/bundled/cbits/ref10/fe_isnegative.c @@ -0,0 +1,16 @@ +#include "fe.h" + +/* +return 1 if f is in {1,3,5,...,q-2} +return 0 if f is in {0,2,4,...,q-1} + +Preconditions: + |f| bounded by 1.1*2^26,1.1*2^25,1.1*2^26,1.1*2^25,etc. +*/ + +static inline int fe_isnegative(const fe f) +{ + unsigned char s[32]; + fe_tobytes(s,f); + return s[0] & 1; +} diff --git a/bundled/cbits/ref10/fe_isnonzero.c b/bundled/cbits/ref10/fe_isnonzero.c new file mode 100644 index 0000000..44b1009 --- /dev/null +++ b/bundled/cbits/ref10/fe_isnonzero.c @@ -0,0 +1,19 @@ +#include "fe.h" +#include "crypto_verify.h" + +/* +return 1 if f == 0 +return 0 if f != 0 + +Preconditions: + |f| bounded by 1.1*2^26,1.1*2^25,1.1*2^26,1.1*2^25,etc. +*/ + +static const unsigned char zero[32]; + +static inline int fe_isnonzero(const fe f) +{ + unsigned char s[32]; + fe_tobytes(s,f); + return crypto_verify_32(s,zero); +} diff --git a/bundled/cbits/ref10/fe_mul.c b/bundled/cbits/ref10/fe_mul.c new file mode 100644 index 0000000..49d1e2a --- /dev/null +++ b/bundled/cbits/ref10/fe_mul.c @@ -0,0 +1,253 @@ +#include "fe.h" +#include "crypto_int64.h" + +/* +h = f * g +Can overlap h with f or g. + +Preconditions: + |f| bounded by 1.65*2^26,1.65*2^25,1.65*2^26,1.65*2^25,etc. + |g| bounded by 1.65*2^26,1.65*2^25,1.65*2^26,1.65*2^25,etc. + +Postconditions: + |h| bounded by 1.01*2^25,1.01*2^24,1.01*2^25,1.01*2^24,etc. +*/ + +/* +Notes on implementation strategy: + +Using schoolbook multiplication. +Karatsuba would save a little in some cost models. + +Most multiplications by 2 and 19 are 32-bit precomputations; +cheaper than 64-bit postcomputations. + +There is one remaining multiplication by 19 in the carry chain; +one *19 precomputation can be merged into this, +but the resulting data flow is considerably less clean. + +There are 12 carries below. +10 of them are 2-way parallelizable and vectorizable. +Can get away with 11 carries, but then data flow is much deeper. + +With tighter constraints on inputs can squeeze carries into int32. +*/ + +static inline void fe_mul(fe h,const fe f,const fe g) +{ + crypto_int32 f0 = f[0]; + crypto_int32 f1 = f[1]; + crypto_int32 f2 = f[2]; + crypto_int32 f3 = f[3]; + crypto_int32 f4 = f[4]; + crypto_int32 f5 = f[5]; + crypto_int32 f6 = f[6]; + crypto_int32 f7 = f[7]; + crypto_int32 f8 = f[8]; + crypto_int32 f9 = f[9]; + crypto_int32 g0 = g[0]; + crypto_int32 g1 = g[1]; + crypto_int32 g2 = g[2]; + crypto_int32 g3 = g[3]; + crypto_int32 g4 = g[4]; + crypto_int32 g5 = g[5]; + crypto_int32 g6 = g[6]; + crypto_int32 g7 = g[7]; + crypto_int32 g8 = g[8]; + crypto_int32 g9 = g[9]; + crypto_int32 g1_19 = 19 * g1; /* 1.959375*2^29 */ + crypto_int32 g2_19 = 19 * g2; /* 1.959375*2^30; still ok */ + crypto_int32 g3_19 = 19 * g3; + crypto_int32 g4_19 = 19 * g4; + crypto_int32 g5_19 = 19 * g5; + crypto_int32 g6_19 = 19 * g6; + crypto_int32 g7_19 = 19 * g7; + crypto_int32 g8_19 = 19 * g8; + crypto_int32 g9_19 = 19 * g9; + crypto_int32 f1_2 = 2 * f1; + crypto_int32 f3_2 = 2 * f3; + crypto_int32 f5_2 = 2 * f5; + crypto_int32 f7_2 = 2 * f7; + crypto_int32 f9_2 = 2 * f9; + crypto_int64 f0g0 = f0 * (crypto_int64) g0; + crypto_int64 f0g1 = f0 * (crypto_int64) g1; + crypto_int64 f0g2 = f0 * (crypto_int64) g2; + crypto_int64 f0g3 = f0 * (crypto_int64) g3; + crypto_int64 f0g4 = f0 * (crypto_int64) g4; + crypto_int64 f0g5 = f0 * (crypto_int64) g5; + crypto_int64 f0g6 = f0 * (crypto_int64) g6; + crypto_int64 f0g7 = f0 * (crypto_int64) g7; + crypto_int64 f0g8 = f0 * (crypto_int64) g8; + crypto_int64 f0g9 = f0 * (crypto_int64) g9; + crypto_int64 f1g0 = f1 * (crypto_int64) g0; + crypto_int64 f1g1_2 = f1_2 * (crypto_int64) g1; + crypto_int64 f1g2 = f1 * (crypto_int64) g2; + crypto_int64 f1g3_2 = f1_2 * (crypto_int64) g3; + crypto_int64 f1g4 = f1 * (crypto_int64) g4; + crypto_int64 f1g5_2 = f1_2 * (crypto_int64) g5; + crypto_int64 f1g6 = f1 * (crypto_int64) g6; + crypto_int64 f1g7_2 = f1_2 * (crypto_int64) g7; + crypto_int64 f1g8 = f1 * (crypto_int64) g8; + crypto_int64 f1g9_38 = f1_2 * (crypto_int64) g9_19; + crypto_int64 f2g0 = f2 * (crypto_int64) g0; + crypto_int64 f2g1 = f2 * (crypto_int64) g1; + crypto_int64 f2g2 = f2 * (crypto_int64) g2; + crypto_int64 f2g3 = f2 * (crypto_int64) g3; + crypto_int64 f2g4 = f2 * (crypto_int64) g4; + crypto_int64 f2g5 = f2 * (crypto_int64) g5; + crypto_int64 f2g6 = f2 * (crypto_int64) g6; + crypto_int64 f2g7 = f2 * (crypto_int64) g7; + crypto_int64 f2g8_19 = f2 * (crypto_int64) g8_19; + crypto_int64 f2g9_19 = f2 * (crypto_int64) g9_19; + crypto_int64 f3g0 = f3 * (crypto_int64) g0; + crypto_int64 f3g1_2 = f3_2 * (crypto_int64) g1; + crypto_int64 f3g2 = f3 * (crypto_int64) g2; + crypto_int64 f3g3_2 = f3_2 * (crypto_int64) g3; + crypto_int64 f3g4 = f3 * (crypto_int64) g4; + crypto_int64 f3g5_2 = f3_2 * (crypto_int64) g5; + crypto_int64 f3g6 = f3 * (crypto_int64) g6; + crypto_int64 f3g7_38 = f3_2 * (crypto_int64) g7_19; + crypto_int64 f3g8_19 = f3 * (crypto_int64) g8_19; + crypto_int64 f3g9_38 = f3_2 * (crypto_int64) g9_19; + crypto_int64 f4g0 = f4 * (crypto_int64) g0; + crypto_int64 f4g1 = f4 * (crypto_int64) g1; + crypto_int64 f4g2 = f4 * (crypto_int64) g2; + crypto_int64 f4g3 = f4 * (crypto_int64) g3; + crypto_int64 f4g4 = f4 * (crypto_int64) g4; + crypto_int64 f4g5 = f4 * (crypto_int64) g5; + crypto_int64 f4g6_19 = f4 * (crypto_int64) g6_19; + crypto_int64 f4g7_19 = f4 * (crypto_int64) g7_19; + crypto_int64 f4g8_19 = f4 * (crypto_int64) g8_19; + crypto_int64 f4g9_19 = f4 * (crypto_int64) g9_19; + crypto_int64 f5g0 = f5 * (crypto_int64) g0; + crypto_int64 f5g1_2 = f5_2 * (crypto_int64) g1; + crypto_int64 f5g2 = f5 * (crypto_int64) g2; + crypto_int64 f5g3_2 = f5_2 * (crypto_int64) g3; + crypto_int64 f5g4 = f5 * (crypto_int64) g4; + crypto_int64 f5g5_38 = f5_2 * (crypto_int64) g5_19; + crypto_int64 f5g6_19 = f5 * (crypto_int64) g6_19; + crypto_int64 f5g7_38 = f5_2 * (crypto_int64) g7_19; + crypto_int64 f5g8_19 = f5 * (crypto_int64) g8_19; + crypto_int64 f5g9_38 = f5_2 * (crypto_int64) g9_19; + crypto_int64 f6g0 = f6 * (crypto_int64) g0; + crypto_int64 f6g1 = f6 * (crypto_int64) g1; + crypto_int64 f6g2 = f6 * (crypto_int64) g2; + crypto_int64 f6g3 = f6 * (crypto_int64) g3; + crypto_int64 f6g4_19 = f6 * (crypto_int64) g4_19; + crypto_int64 f6g5_19 = f6 * (crypto_int64) g5_19; + crypto_int64 f6g6_19 = f6 * (crypto_int64) g6_19; + crypto_int64 f6g7_19 = f6 * (crypto_int64) g7_19; + crypto_int64 f6g8_19 = f6 * (crypto_int64) g8_19; + crypto_int64 f6g9_19 = f6 * (crypto_int64) g9_19; + crypto_int64 f7g0 = f7 * (crypto_int64) g0; + crypto_int64 f7g1_2 = f7_2 * (crypto_int64) g1; + crypto_int64 f7g2 = f7 * (crypto_int64) g2; + crypto_int64 f7g3_38 = f7_2 * (crypto_int64) g3_19; + crypto_int64 f7g4_19 = f7 * (crypto_int64) g4_19; + crypto_int64 f7g5_38 = f7_2 * (crypto_int64) g5_19; + crypto_int64 f7g6_19 = f7 * (crypto_int64) g6_19; + crypto_int64 f7g7_38 = f7_2 * (crypto_int64) g7_19; + crypto_int64 f7g8_19 = f7 * (crypto_int64) g8_19; + crypto_int64 f7g9_38 = f7_2 * (crypto_int64) g9_19; + crypto_int64 f8g0 = f8 * (crypto_int64) g0; + crypto_int64 f8g1 = f8 * (crypto_int64) g1; + crypto_int64 f8g2_19 = f8 * (crypto_int64) g2_19; + crypto_int64 f8g3_19 = f8 * (crypto_int64) g3_19; + crypto_int64 f8g4_19 = f8 * (crypto_int64) g4_19; + crypto_int64 f8g5_19 = f8 * (crypto_int64) g5_19; + crypto_int64 f8g6_19 = f8 * (crypto_int64) g6_19; + crypto_int64 f8g7_19 = f8 * (crypto_int64) g7_19; + crypto_int64 f8g8_19 = f8 * (crypto_int64) g8_19; + crypto_int64 f8g9_19 = f8 * (crypto_int64) g9_19; + crypto_int64 f9g0 = f9 * (crypto_int64) g0; + crypto_int64 f9g1_38 = f9_2 * (crypto_int64) g1_19; + crypto_int64 f9g2_19 = f9 * (crypto_int64) g2_19; + crypto_int64 f9g3_38 = f9_2 * (crypto_int64) g3_19; + crypto_int64 f9g4_19 = f9 * (crypto_int64) g4_19; + crypto_int64 f9g5_38 = f9_2 * (crypto_int64) g5_19; + crypto_int64 f9g6_19 = f9 * (crypto_int64) g6_19; + crypto_int64 f9g7_38 = f9_2 * (crypto_int64) g7_19; + crypto_int64 f9g8_19 = f9 * (crypto_int64) g8_19; + crypto_int64 f9g9_38 = f9_2 * (crypto_int64) g9_19; + crypto_int64 h0 = f0g0+f1g9_38+f2g8_19+f3g7_38+f4g6_19+f5g5_38+f6g4_19+f7g3_38+f8g2_19+f9g1_38; + crypto_int64 h1 = f0g1+f1g0 +f2g9_19+f3g8_19+f4g7_19+f5g6_19+f6g5_19+f7g4_19+f8g3_19+f9g2_19; + crypto_int64 h2 = f0g2+f1g1_2 +f2g0 +f3g9_38+f4g8_19+f5g7_38+f6g6_19+f7g5_38+f8g4_19+f9g3_38; + crypto_int64 h3 = f0g3+f1g2 +f2g1 +f3g0 +f4g9_19+f5g8_19+f6g7_19+f7g6_19+f8g5_19+f9g4_19; + crypto_int64 h4 = f0g4+f1g3_2 +f2g2 +f3g1_2 +f4g0 +f5g9_38+f6g8_19+f7g7_38+f8g6_19+f9g5_38; + crypto_int64 h5 = f0g5+f1g4 +f2g3 +f3g2 +f4g1 +f5g0 +f6g9_19+f7g8_19+f8g7_19+f9g6_19; + crypto_int64 h6 = f0g6+f1g5_2 +f2g4 +f3g3_2 +f4g2 +f5g1_2 +f6g0 +f7g9_38+f8g8_19+f9g7_38; + crypto_int64 h7 = f0g7+f1g6 +f2g5 +f3g4 +f4g3 +f5g2 +f6g1 +f7g0 +f8g9_19+f9g8_19; + crypto_int64 h8 = f0g8+f1g7_2 +f2g6 +f3g5_2 +f4g4 +f5g3_2 +f6g2 +f7g1_2 +f8g0 +f9g9_38; + crypto_int64 h9 = f0g9+f1g8 +f2g7 +f3g6 +f4g5 +f5g4 +f6g3 +f7g2 +f8g1 +f9g0 ; + crypto_int64 carry0; + crypto_int64 carry1; + crypto_int64 carry2; + crypto_int64 carry3; + crypto_int64 carry4; + crypto_int64 carry5; + crypto_int64 carry6; + crypto_int64 carry7; + crypto_int64 carry8; + crypto_int64 carry9; + + /* + |h0| <= (1.65*1.65*2^52*(1+19+19+19+19)+1.65*1.65*2^50*(38+38+38+38+38)) + i.e. |h0| <= 1.4*2^60; narrower ranges for h2, h4, h6, h8 + |h1| <= (1.65*1.65*2^51*(1+1+19+19+19+19+19+19+19+19)) + i.e. |h1| <= 1.7*2^59; narrower ranges for h3, h5, h7, h9 + */ + + carry0 = (h0 + (crypto_int64) (1<<25)) >> 26; h1 += carry0; h0 -= carry0 << 26; + carry4 = (h4 + (crypto_int64) (1<<25)) >> 26; h5 += carry4; h4 -= carry4 << 26; + /* |h0| <= 2^25 */ + /* |h4| <= 2^25 */ + /* |h1| <= 1.71*2^59 */ + /* |h5| <= 1.71*2^59 */ + + carry1 = (h1 + (crypto_int64) (1<<24)) >> 25; h2 += carry1; h1 -= carry1 << 25; + carry5 = (h5 + (crypto_int64) (1<<24)) >> 25; h6 += carry5; h5 -= carry5 << 25; + /* |h1| <= 2^24; from now on fits into int32 */ + /* |h5| <= 2^24; from now on fits into int32 */ + /* |h2| <= 1.41*2^60 */ + /* |h6| <= 1.41*2^60 */ + + carry2 = (h2 + (crypto_int64) (1<<25)) >> 26; h3 += carry2; h2 -= carry2 << 26; + carry6 = (h6 + (crypto_int64) (1<<25)) >> 26; h7 += carry6; h6 -= carry6 << 26; + /* |h2| <= 2^25; from now on fits into int32 unchanged */ + /* |h6| <= 2^25; from now on fits into int32 unchanged */ + /* |h3| <= 1.71*2^59 */ + /* |h7| <= 1.71*2^59 */ + + carry3 = (h3 + (crypto_int64) (1<<24)) >> 25; h4 += carry3; h3 -= carry3 << 25; + carry7 = (h7 + (crypto_int64) (1<<24)) >> 25; h8 += carry7; h7 -= carry7 << 25; + /* |h3| <= 2^24; from now on fits into int32 unchanged */ + /* |h7| <= 2^24; from now on fits into int32 unchanged */ + /* |h4| <= 1.72*2^34 */ + /* |h8| <= 1.41*2^60 */ + + carry4 = (h4 + (crypto_int64) (1<<25)) >> 26; h5 += carry4; h4 -= carry4 << 26; + carry8 = (h8 + (crypto_int64) (1<<25)) >> 26; h9 += carry8; h8 -= carry8 << 26; + /* |h4| <= 2^25; from now on fits into int32 unchanged */ + /* |h8| <= 2^25; from now on fits into int32 unchanged */ + /* |h5| <= 1.01*2^24 */ + /* |h9| <= 1.71*2^59 */ + + carry9 = (h9 + (crypto_int64) (1<<24)) >> 25; h0 += carry9 * 19; h9 -= carry9 << 25; + /* |h9| <= 2^24; from now on fits into int32 unchanged */ + /* |h0| <= 1.1*2^39 */ + + carry0 = (h0 + (crypto_int64) (1<<25)) >> 26; h1 += carry0; h0 -= carry0 << 26; + /* |h0| <= 2^25; from now on fits into int32 unchanged */ + /* |h1| <= 1.01*2^24 */ + + h[0] = h0; + h[1] = h1; + h[2] = h2; + h[3] = h3; + h[4] = h4; + h[5] = h5; + h[6] = h6; + h[7] = h7; + h[8] = h8; + h[9] = h9; +} diff --git a/bundled/cbits/ref10/fe_neg.c b/bundled/cbits/ref10/fe_neg.c new file mode 100644 index 0000000..de31d92 --- /dev/null +++ b/bundled/cbits/ref10/fe_neg.c @@ -0,0 +1,45 @@ +#include "fe.h" + +/* +h = -f + +Preconditions: + |f| bounded by 1.1*2^25,1.1*2^24,1.1*2^25,1.1*2^24,etc. + +Postconditions: + |h| bounded by 1.1*2^25,1.1*2^24,1.1*2^25,1.1*2^24,etc. +*/ + +static inline void fe_neg(fe h,const fe f) +{ + crypto_int32 f0 = f[0]; + crypto_int32 f1 = f[1]; + crypto_int32 f2 = f[2]; + crypto_int32 f3 = f[3]; + crypto_int32 f4 = f[4]; + crypto_int32 f5 = f[5]; + crypto_int32 f6 = f[6]; + crypto_int32 f7 = f[7]; + crypto_int32 f8 = f[8]; + crypto_int32 f9 = f[9]; + crypto_int32 h0 = -f0; + crypto_int32 h1 = -f1; + crypto_int32 h2 = -f2; + crypto_int32 h3 = -f3; + crypto_int32 h4 = -f4; + crypto_int32 h5 = -f5; + crypto_int32 h6 = -f6; + crypto_int32 h7 = -f7; + crypto_int32 h8 = -f8; + crypto_int32 h9 = -f9; + h[0] = h0; + h[1] = h1; + h[2] = h2; + h[3] = h3; + h[4] = h4; + h[5] = h5; + h[6] = h6; + h[7] = h7; + h[8] = h8; + h[9] = h9; +} diff --git a/bundled/cbits/ref10/fe_pow22523.c b/bundled/cbits/ref10/fe_pow22523.c new file mode 100644 index 0000000..3aae083 --- /dev/null +++ b/bundled/cbits/ref10/fe_pow22523.c @@ -0,0 +1,13 @@ +#include "fe.h" + +static inline void fe_pow22523(fe out,const fe z) +{ + fe t0; + fe t1; + fe t2; + int i; + +#include "pow22523.h" + + return; +} diff --git a/bundled/cbits/ref10/fe_sq.c b/bundled/cbits/ref10/fe_sq.c new file mode 100644 index 0000000..1bf4ad5 --- /dev/null +++ b/bundled/cbits/ref10/fe_sq.c @@ -0,0 +1,149 @@ +#include "fe.h" +#include "crypto_int64.h" + +/* +h = f * f +Can overlap h with f. + +Preconditions: + |f| bounded by 1.65*2^26,1.65*2^25,1.65*2^26,1.65*2^25,etc. + +Postconditions: + |h| bounded by 1.01*2^25,1.01*2^24,1.01*2^25,1.01*2^24,etc. +*/ + +/* +See fe_mul.c for discussion of implementation strategy. +*/ + +static inline void fe_sq(fe h,const fe f) +{ + crypto_int32 f0 = f[0]; + crypto_int32 f1 = f[1]; + crypto_int32 f2 = f[2]; + crypto_int32 f3 = f[3]; + crypto_int32 f4 = f[4]; + crypto_int32 f5 = f[5]; + crypto_int32 f6 = f[6]; + crypto_int32 f7 = f[7]; + crypto_int32 f8 = f[8]; + crypto_int32 f9 = f[9]; + crypto_int32 f0_2 = 2 * f0; + crypto_int32 f1_2 = 2 * f1; + crypto_int32 f2_2 = 2 * f2; + crypto_int32 f3_2 = 2 * f3; + crypto_int32 f4_2 = 2 * f4; + crypto_int32 f5_2 = 2 * f5; + crypto_int32 f6_2 = 2 * f6; + crypto_int32 f7_2 = 2 * f7; + crypto_int32 f5_38 = 38 * f5; /* 1.959375*2^30 */ + crypto_int32 f6_19 = 19 * f6; /* 1.959375*2^30 */ + crypto_int32 f7_38 = 38 * f7; /* 1.959375*2^30 */ + crypto_int32 f8_19 = 19 * f8; /* 1.959375*2^30 */ + crypto_int32 f9_38 = 38 * f9; /* 1.959375*2^30 */ + crypto_int64 f0f0 = f0 * (crypto_int64) f0; + crypto_int64 f0f1_2 = f0_2 * (crypto_int64) f1; + crypto_int64 f0f2_2 = f0_2 * (crypto_int64) f2; + crypto_int64 f0f3_2 = f0_2 * (crypto_int64) f3; + crypto_int64 f0f4_2 = f0_2 * (crypto_int64) f4; + crypto_int64 f0f5_2 = f0_2 * (crypto_int64) f5; + crypto_int64 f0f6_2 = f0_2 * (crypto_int64) f6; + crypto_int64 f0f7_2 = f0_2 * (crypto_int64) f7; + crypto_int64 f0f8_2 = f0_2 * (crypto_int64) f8; + crypto_int64 f0f9_2 = f0_2 * (crypto_int64) f9; + crypto_int64 f1f1_2 = f1_2 * (crypto_int64) f1; + crypto_int64 f1f2_2 = f1_2 * (crypto_int64) f2; + crypto_int64 f1f3_4 = f1_2 * (crypto_int64) f3_2; + crypto_int64 f1f4_2 = f1_2 * (crypto_int64) f4; + crypto_int64 f1f5_4 = f1_2 * (crypto_int64) f5_2; + crypto_int64 f1f6_2 = f1_2 * (crypto_int64) f6; + crypto_int64 f1f7_4 = f1_2 * (crypto_int64) f7_2; + crypto_int64 f1f8_2 = f1_2 * (crypto_int64) f8; + crypto_int64 f1f9_76 = f1_2 * (crypto_int64) f9_38; + crypto_int64 f2f2 = f2 * (crypto_int64) f2; + crypto_int64 f2f3_2 = f2_2 * (crypto_int64) f3; + crypto_int64 f2f4_2 = f2_2 * (crypto_int64) f4; + crypto_int64 f2f5_2 = f2_2 * (crypto_int64) f5; + crypto_int64 f2f6_2 = f2_2 * (crypto_int64) f6; + crypto_int64 f2f7_2 = f2_2 * (crypto_int64) f7; + crypto_int64 f2f8_38 = f2_2 * (crypto_int64) f8_19; + crypto_int64 f2f9_38 = f2 * (crypto_int64) f9_38; + crypto_int64 f3f3_2 = f3_2 * (crypto_int64) f3; + crypto_int64 f3f4_2 = f3_2 * (crypto_int64) f4; + crypto_int64 f3f5_4 = f3_2 * (crypto_int64) f5_2; + crypto_int64 f3f6_2 = f3_2 * (crypto_int64) f6; + crypto_int64 f3f7_76 = f3_2 * (crypto_int64) f7_38; + crypto_int64 f3f8_38 = f3_2 * (crypto_int64) f8_19; + crypto_int64 f3f9_76 = f3_2 * (crypto_int64) f9_38; + crypto_int64 f4f4 = f4 * (crypto_int64) f4; + crypto_int64 f4f5_2 = f4_2 * (crypto_int64) f5; + crypto_int64 f4f6_38 = f4_2 * (crypto_int64) f6_19; + crypto_int64 f4f7_38 = f4 * (crypto_int64) f7_38; + crypto_int64 f4f8_38 = f4_2 * (crypto_int64) f8_19; + crypto_int64 f4f9_38 = f4 * (crypto_int64) f9_38; + crypto_int64 f5f5_38 = f5 * (crypto_int64) f5_38; + crypto_int64 f5f6_38 = f5_2 * (crypto_int64) f6_19; + crypto_int64 f5f7_76 = f5_2 * (crypto_int64) f7_38; + crypto_int64 f5f8_38 = f5_2 * (crypto_int64) f8_19; + crypto_int64 f5f9_76 = f5_2 * (crypto_int64) f9_38; + crypto_int64 f6f6_19 = f6 * (crypto_int64) f6_19; + crypto_int64 f6f7_38 = f6 * (crypto_int64) f7_38; + crypto_int64 f6f8_38 = f6_2 * (crypto_int64) f8_19; + crypto_int64 f6f9_38 = f6 * (crypto_int64) f9_38; + crypto_int64 f7f7_38 = f7 * (crypto_int64) f7_38; + crypto_int64 f7f8_38 = f7_2 * (crypto_int64) f8_19; + crypto_int64 f7f9_76 = f7_2 * (crypto_int64) f9_38; + crypto_int64 f8f8_19 = f8 * (crypto_int64) f8_19; + crypto_int64 f8f9_38 = f8 * (crypto_int64) f9_38; + crypto_int64 f9f9_38 = f9 * (crypto_int64) f9_38; + crypto_int64 h0 = f0f0 +f1f9_76+f2f8_38+f3f7_76+f4f6_38+f5f5_38; + crypto_int64 h1 = f0f1_2+f2f9_38+f3f8_38+f4f7_38+f5f6_38; + crypto_int64 h2 = f0f2_2+f1f1_2 +f3f9_76+f4f8_38+f5f7_76+f6f6_19; + crypto_int64 h3 = f0f3_2+f1f2_2 +f4f9_38+f5f8_38+f6f7_38; + crypto_int64 h4 = f0f4_2+f1f3_4 +f2f2 +f5f9_76+f6f8_38+f7f7_38; + crypto_int64 h5 = f0f5_2+f1f4_2 +f2f3_2 +f6f9_38+f7f8_38; + crypto_int64 h6 = f0f6_2+f1f5_4 +f2f4_2 +f3f3_2 +f7f9_76+f8f8_19; + crypto_int64 h7 = f0f7_2+f1f6_2 +f2f5_2 +f3f4_2 +f8f9_38; + crypto_int64 h8 = f0f8_2+f1f7_4 +f2f6_2 +f3f5_4 +f4f4 +f9f9_38; + crypto_int64 h9 = f0f9_2+f1f8_2 +f2f7_2 +f3f6_2 +f4f5_2; + crypto_int64 carry0; + crypto_int64 carry1; + crypto_int64 carry2; + crypto_int64 carry3; + crypto_int64 carry4; + crypto_int64 carry5; + crypto_int64 carry6; + crypto_int64 carry7; + crypto_int64 carry8; + crypto_int64 carry9; + + carry0 = (h0 + (crypto_int64) (1<<25)) >> 26; h1 += carry0; h0 -= carry0 << 26; + carry4 = (h4 + (crypto_int64) (1<<25)) >> 26; h5 += carry4; h4 -= carry4 << 26; + + carry1 = (h1 + (crypto_int64) (1<<24)) >> 25; h2 += carry1; h1 -= carry1 << 25; + carry5 = (h5 + (crypto_int64) (1<<24)) >> 25; h6 += carry5; h5 -= carry5 << 25; + + carry2 = (h2 + (crypto_int64) (1<<25)) >> 26; h3 += carry2; h2 -= carry2 << 26; + carry6 = (h6 + (crypto_int64) (1<<25)) >> 26; h7 += carry6; h6 -= carry6 << 26; + + carry3 = (h3 + (crypto_int64) (1<<24)) >> 25; h4 += carry3; h3 -= carry3 << 25; + carry7 = (h7 + (crypto_int64) (1<<24)) >> 25; h8 += carry7; h7 -= carry7 << 25; + + carry4 = (h4 + (crypto_int64) (1<<25)) >> 26; h5 += carry4; h4 -= carry4 << 26; + carry8 = (h8 + (crypto_int64) (1<<25)) >> 26; h9 += carry8; h8 -= carry8 << 26; + + carry9 = (h9 + (crypto_int64) (1<<24)) >> 25; h0 += carry9 * 19; h9 -= carry9 << 25; + + carry0 = (h0 + (crypto_int64) (1<<25)) >> 26; h1 += carry0; h0 -= carry0 << 26; + + h[0] = h0; + h[1] = h1; + h[2] = h2; + h[3] = h3; + h[4] = h4; + h[5] = h5; + h[6] = h6; + h[7] = h7; + h[8] = h8; + h[9] = h9; +} diff --git a/bundled/cbits/ref10/fe_sq2.c b/bundled/cbits/ref10/fe_sq2.c new file mode 100644 index 0000000..ea995c4 --- /dev/null +++ b/bundled/cbits/ref10/fe_sq2.c @@ -0,0 +1,160 @@ +#include "fe.h" +#include "crypto_int64.h" + +/* +h = 2 * f * f +Can overlap h with f. + +Preconditions: + |f| bounded by 1.65*2^26,1.65*2^25,1.65*2^26,1.65*2^25,etc. + +Postconditions: + |h| bounded by 1.01*2^25,1.01*2^24,1.01*2^25,1.01*2^24,etc. +*/ + +/* +See fe_mul.c for discussion of implementation strategy. +*/ + +static inline void fe_sq2(fe h,const fe f) +{ + crypto_int32 f0 = f[0]; + crypto_int32 f1 = f[1]; + crypto_int32 f2 = f[2]; + crypto_int32 f3 = f[3]; + crypto_int32 f4 = f[4]; + crypto_int32 f5 = f[5]; + crypto_int32 f6 = f[6]; + crypto_int32 f7 = f[7]; + crypto_int32 f8 = f[8]; + crypto_int32 f9 = f[9]; + crypto_int32 f0_2 = 2 * f0; + crypto_int32 f1_2 = 2 * f1; + crypto_int32 f2_2 = 2 * f2; + crypto_int32 f3_2 = 2 * f3; + crypto_int32 f4_2 = 2 * f4; + crypto_int32 f5_2 = 2 * f5; + crypto_int32 f6_2 = 2 * f6; + crypto_int32 f7_2 = 2 * f7; + crypto_int32 f5_38 = 38 * f5; /* 1.959375*2^30 */ + crypto_int32 f6_19 = 19 * f6; /* 1.959375*2^30 */ + crypto_int32 f7_38 = 38 * f7; /* 1.959375*2^30 */ + crypto_int32 f8_19 = 19 * f8; /* 1.959375*2^30 */ + crypto_int32 f9_38 = 38 * f9; /* 1.959375*2^30 */ + crypto_int64 f0f0 = f0 * (crypto_int64) f0; + crypto_int64 f0f1_2 = f0_2 * (crypto_int64) f1; + crypto_int64 f0f2_2 = f0_2 * (crypto_int64) f2; + crypto_int64 f0f3_2 = f0_2 * (crypto_int64) f3; + crypto_int64 f0f4_2 = f0_2 * (crypto_int64) f4; + crypto_int64 f0f5_2 = f0_2 * (crypto_int64) f5; + crypto_int64 f0f6_2 = f0_2 * (crypto_int64) f6; + crypto_int64 f0f7_2 = f0_2 * (crypto_int64) f7; + crypto_int64 f0f8_2 = f0_2 * (crypto_int64) f8; + crypto_int64 f0f9_2 = f0_2 * (crypto_int64) f9; + crypto_int64 f1f1_2 = f1_2 * (crypto_int64) f1; + crypto_int64 f1f2_2 = f1_2 * (crypto_int64) f2; + crypto_int64 f1f3_4 = f1_2 * (crypto_int64) f3_2; + crypto_int64 f1f4_2 = f1_2 * (crypto_int64) f4; + crypto_int64 f1f5_4 = f1_2 * (crypto_int64) f5_2; + crypto_int64 f1f6_2 = f1_2 * (crypto_int64) f6; + crypto_int64 f1f7_4 = f1_2 * (crypto_int64) f7_2; + crypto_int64 f1f8_2 = f1_2 * (crypto_int64) f8; + crypto_int64 f1f9_76 = f1_2 * (crypto_int64) f9_38; + crypto_int64 f2f2 = f2 * (crypto_int64) f2; + crypto_int64 f2f3_2 = f2_2 * (crypto_int64) f3; + crypto_int64 f2f4_2 = f2_2 * (crypto_int64) f4; + crypto_int64 f2f5_2 = f2_2 * (crypto_int64) f5; + crypto_int64 f2f6_2 = f2_2 * (crypto_int64) f6; + crypto_int64 f2f7_2 = f2_2 * (crypto_int64) f7; + crypto_int64 f2f8_38 = f2_2 * (crypto_int64) f8_19; + crypto_int64 f2f9_38 = f2 * (crypto_int64) f9_38; + crypto_int64 f3f3_2 = f3_2 * (crypto_int64) f3; + crypto_int64 f3f4_2 = f3_2 * (crypto_int64) f4; + crypto_int64 f3f5_4 = f3_2 * (crypto_int64) f5_2; + crypto_int64 f3f6_2 = f3_2 * (crypto_int64) f6; + crypto_int64 f3f7_76 = f3_2 * (crypto_int64) f7_38; + crypto_int64 f3f8_38 = f3_2 * (crypto_int64) f8_19; + crypto_int64 f3f9_76 = f3_2 * (crypto_int64) f9_38; + crypto_int64 f4f4 = f4 * (crypto_int64) f4; + crypto_int64 f4f5_2 = f4_2 * (crypto_int64) f5; + crypto_int64 f4f6_38 = f4_2 * (crypto_int64) f6_19; + crypto_int64 f4f7_38 = f4 * (crypto_int64) f7_38; + crypto_int64 f4f8_38 = f4_2 * (crypto_int64) f8_19; + crypto_int64 f4f9_38 = f4 * (crypto_int64) f9_38; + crypto_int64 f5f5_38 = f5 * (crypto_int64) f5_38; + crypto_int64 f5f6_38 = f5_2 * (crypto_int64) f6_19; + crypto_int64 f5f7_76 = f5_2 * (crypto_int64) f7_38; + crypto_int64 f5f8_38 = f5_2 * (crypto_int64) f8_19; + crypto_int64 f5f9_76 = f5_2 * (crypto_int64) f9_38; + crypto_int64 f6f6_19 = f6 * (crypto_int64) f6_19; + crypto_int64 f6f7_38 = f6 * (crypto_int64) f7_38; + crypto_int64 f6f8_38 = f6_2 * (crypto_int64) f8_19; + crypto_int64 f6f9_38 = f6 * (crypto_int64) f9_38; + crypto_int64 f7f7_38 = f7 * (crypto_int64) f7_38; + crypto_int64 f7f8_38 = f7_2 * (crypto_int64) f8_19; + crypto_int64 f7f9_76 = f7_2 * (crypto_int64) f9_38; + crypto_int64 f8f8_19 = f8 * (crypto_int64) f8_19; + crypto_int64 f8f9_38 = f8 * (crypto_int64) f9_38; + crypto_int64 f9f9_38 = f9 * (crypto_int64) f9_38; + crypto_int64 h0 = f0f0 +f1f9_76+f2f8_38+f3f7_76+f4f6_38+f5f5_38; + crypto_int64 h1 = f0f1_2+f2f9_38+f3f8_38+f4f7_38+f5f6_38; + crypto_int64 h2 = f0f2_2+f1f1_2 +f3f9_76+f4f8_38+f5f7_76+f6f6_19; + crypto_int64 h3 = f0f3_2+f1f2_2 +f4f9_38+f5f8_38+f6f7_38; + crypto_int64 h4 = f0f4_2+f1f3_4 +f2f2 +f5f9_76+f6f8_38+f7f7_38; + crypto_int64 h5 = f0f5_2+f1f4_2 +f2f3_2 +f6f9_38+f7f8_38; + crypto_int64 h6 = f0f6_2+f1f5_4 +f2f4_2 +f3f3_2 +f7f9_76+f8f8_19; + crypto_int64 h7 = f0f7_2+f1f6_2 +f2f5_2 +f3f4_2 +f8f9_38; + crypto_int64 h8 = f0f8_2+f1f7_4 +f2f6_2 +f3f5_4 +f4f4 +f9f9_38; + crypto_int64 h9 = f0f9_2+f1f8_2 +f2f7_2 +f3f6_2 +f4f5_2; + crypto_int64 carry0; + crypto_int64 carry1; + crypto_int64 carry2; + crypto_int64 carry3; + crypto_int64 carry4; + crypto_int64 carry5; + crypto_int64 carry6; + crypto_int64 carry7; + crypto_int64 carry8; + crypto_int64 carry9; + + h0 += h0; + h1 += h1; + h2 += h2; + h3 += h3; + h4 += h4; + h5 += h5; + h6 += h6; + h7 += h7; + h8 += h8; + h9 += h9; + + carry0 = (h0 + (crypto_int64) (1<<25)) >> 26; h1 += carry0; h0 -= carry0 << 26; + carry4 = (h4 + (crypto_int64) (1<<25)) >> 26; h5 += carry4; h4 -= carry4 << 26; + + carry1 = (h1 + (crypto_int64) (1<<24)) >> 25; h2 += carry1; h1 -= carry1 << 25; + carry5 = (h5 + (crypto_int64) (1<<24)) >> 25; h6 += carry5; h5 -= carry5 << 25; + + carry2 = (h2 + (crypto_int64) (1<<25)) >> 26; h3 += carry2; h2 -= carry2 << 26; + carry6 = (h6 + (crypto_int64) (1<<25)) >> 26; h7 += carry6; h6 -= carry6 << 26; + + carry3 = (h3 + (crypto_int64) (1<<24)) >> 25; h4 += carry3; h3 -= carry3 << 25; + carry7 = (h7 + (crypto_int64) (1<<24)) >> 25; h8 += carry7; h7 -= carry7 << 25; + + carry4 = (h4 + (crypto_int64) (1<<25)) >> 26; h5 += carry4; h4 -= carry4 << 26; + carry8 = (h8 + (crypto_int64) (1<<25)) >> 26; h9 += carry8; h8 -= carry8 << 26; + + carry9 = (h9 + (crypto_int64) (1<<24)) >> 25; h0 += carry9 * 19; h9 -= carry9 << 25; + + carry0 = (h0 + (crypto_int64) (1<<25)) >> 26; h1 += carry0; h0 -= carry0 << 26; + + h[0] = h0; + h[1] = h1; + h[2] = h2; + h[3] = h3; + h[4] = h4; + h[5] = h5; + h[6] = h6; + h[7] = h7; + h[8] = h8; + h[9] = h9; +} diff --git a/bundled/cbits/ref10/fe_sub.c b/bundled/cbits/ref10/fe_sub.c new file mode 100644 index 0000000..305c120 --- /dev/null +++ b/bundled/cbits/ref10/fe_sub.c @@ -0,0 +1,57 @@ +#include "fe.h" + +/* +h = f - g +Can overlap h with f or g. + +Preconditions: + |f| bounded by 1.1*2^25,1.1*2^24,1.1*2^25,1.1*2^24,etc. + |g| bounded by 1.1*2^25,1.1*2^24,1.1*2^25,1.1*2^24,etc. + +Postconditions: + |h| bounded by 1.1*2^26,1.1*2^25,1.1*2^26,1.1*2^25,etc. +*/ + +static inline void fe_sub(fe h,const fe f,const fe g) +{ + crypto_int32 f0 = f[0]; + crypto_int32 f1 = f[1]; + crypto_int32 f2 = f[2]; + crypto_int32 f3 = f[3]; + crypto_int32 f4 = f[4]; + crypto_int32 f5 = f[5]; + crypto_int32 f6 = f[6]; + crypto_int32 f7 = f[7]; + crypto_int32 f8 = f[8]; + crypto_int32 f9 = f[9]; + crypto_int32 g0 = g[0]; + crypto_int32 g1 = g[1]; + crypto_int32 g2 = g[2]; + crypto_int32 g3 = g[3]; + crypto_int32 g4 = g[4]; + crypto_int32 g5 = g[5]; + crypto_int32 g6 = g[6]; + crypto_int32 g7 = g[7]; + crypto_int32 g8 = g[8]; + crypto_int32 g9 = g[9]; + crypto_int32 h0 = f0 - g0; + crypto_int32 h1 = f1 - g1; + crypto_int32 h2 = f2 - g2; + crypto_int32 h3 = f3 - g3; + crypto_int32 h4 = f4 - g4; + crypto_int32 h5 = f5 - g5; + crypto_int32 h6 = f6 - g6; + crypto_int32 h7 = f7 - g7; + crypto_int32 h8 = f8 - g8; + crypto_int32 h9 = f9 - g9; + h[0] = h0; + h[1] = h1; + h[2] = h2; + h[3] = h3; + h[4] = h4; + h[5] = h5; + h[6] = h6; + h[7] = h7; + h[8] = h8; + h[9] = h9; +} diff --git a/bundled/cbits/ref10/fe_tobytes.c b/bundled/cbits/ref10/fe_tobytes.c new file mode 100644 index 0000000..bf0f8ce --- /dev/null +++ b/bundled/cbits/ref10/fe_tobytes.c @@ -0,0 +1,119 @@ +#include "fe.h" + +/* +Preconditions: + |h| bounded by 1.1*2^26,1.1*2^25,1.1*2^26,1.1*2^25,etc. + +Write p=2^255-19; q=floor(h/p). +Basic claim: q = floor(2^(-255)(h + 19 2^(-25)h9 + 2^(-1))). + +Proof: + Have |h|<=p so |q|<=1 so |19^2 2^(-255) q|<1/4. + Also have |h-2^230 h9|<2^231 so |19 2^(-255)(h-2^230 h9)|<1/4. + + Write y=2^(-1)-19^2 2^(-255)q-19 2^(-255)(h-2^230 h9). + Then 0> 25; + q = (h0 + q) >> 26; + q = (h1 + q) >> 25; + q = (h2 + q) >> 26; + q = (h3 + q) >> 25; + q = (h4 + q) >> 26; + q = (h5 + q) >> 25; + q = (h6 + q) >> 26; + q = (h7 + q) >> 25; + q = (h8 + q) >> 26; + q = (h9 + q) >> 25; + + /* Goal: Output h-(2^255-19)q, which is between 0 and 2^255-20. */ + h0 += 19 * q; + /* Goal: Output h-2^255 q, which is between 0 and 2^255-20. */ + + carry0 = h0 >> 26; h1 += carry0; h0 -= carry0 << 26; + carry1 = h1 >> 25; h2 += carry1; h1 -= carry1 << 25; + carry2 = h2 >> 26; h3 += carry2; h2 -= carry2 << 26; + carry3 = h3 >> 25; h4 += carry3; h3 -= carry3 << 25; + carry4 = h4 >> 26; h5 += carry4; h4 -= carry4 << 26; + carry5 = h5 >> 25; h6 += carry5; h5 -= carry5 << 25; + carry6 = h6 >> 26; h7 += carry6; h6 -= carry6 << 26; + carry7 = h7 >> 25; h8 += carry7; h7 -= carry7 << 25; + carry8 = h8 >> 26; h9 += carry8; h8 -= carry8 << 26; + carry9 = h9 >> 25; h9 -= carry9 << 25; + /* h10 = carry9 */ + + /* + Goal: Output h0+...+2^255 h10-2^255 q, which is between 0 and 2^255-20. + Have h0+...+2^230 h9 between 0 and 2^255-1; + evidently 2^255 h10-2^255 q = 0. + Goal: Output h0+...+2^230 h9. + */ + + s[0] = h0 >> 0; + s[1] = h0 >> 8; + s[2] = h0 >> 16; + s[3] = (h0 >> 24) | (h1 << 2); + s[4] = h1 >> 6; + s[5] = h1 >> 14; + s[6] = (h1 >> 22) | (h2 << 3); + s[7] = h2 >> 5; + s[8] = h2 >> 13; + s[9] = (h2 >> 21) | (h3 << 5); + s[10] = h3 >> 3; + s[11] = h3 >> 11; + s[12] = (h3 >> 19) | (h4 << 6); + s[13] = h4 >> 2; + s[14] = h4 >> 10; + s[15] = h4 >> 18; + s[16] = h5 >> 0; + s[17] = h5 >> 8; + s[18] = h5 >> 16; + s[19] = (h5 >> 24) | (h6 << 1); + s[20] = h6 >> 7; + s[21] = h6 >> 15; + s[22] = (h6 >> 23) | (h7 << 3); + s[23] = h7 >> 5; + s[24] = h7 >> 13; + s[25] = (h7 >> 21) | (h8 << 4); + s[26] = h8 >> 4; + s[27] = h8 >> 12; + s[28] = (h8 >> 20) | (h9 << 6); + s[29] = h9 >> 2; + s[30] = h9 >> 10; + s[31] = h9 >> 18; +} diff --git a/bundled/cbits/ref10/ge_add.c b/bundled/cbits/ref10/ge_add.c new file mode 100644 index 0000000..d10f2d4 --- /dev/null +++ b/bundled/cbits/ref10/ge_add.c @@ -0,0 +1,11 @@ +#include "ge.h" + +/* +r = p + q +*/ + +static inline void ge_add(ge_p1p1 *r,const ge_p3 *p,const ge_cached *q) +{ + fe t0; +#include "ge_add.h" +} diff --git a/bundled/cbits/ref10/ge_double_scalarmult.c b/bundled/cbits/ref10/ge_double_scalarmult.c new file mode 100644 index 0000000..c4e1be7 --- /dev/null +++ b/bundled/cbits/ref10/ge_double_scalarmult.c @@ -0,0 +1,96 @@ +#include "ge.h" + +static inline void slide(signed char *r,const unsigned char *a) +{ + int i; + int b; + int k; + + for (i = 0;i < 256;++i) + r[i] = 1 & (a[i >> 3] >> (i & 7)); + + for (i = 0;i < 256;++i) + if (r[i]) { + for (b = 1;b <= 6 && i + b < 256;++b) { + if (r[i + b]) { + if (r[i] + (r[i + b] << b) <= 15) { + r[i] += r[i + b] << b; r[i + b] = 0; + } else if (r[i] - (r[i + b] << b) >= -15) { + r[i] -= r[i + b] << b; + for (k = i + b;k < 256;++k) { + if (!r[k]) { + r[k] = 1; + break; + } + r[k] = 0; + } + } else + break; + } + } + } + +} + +static ge_precomp Bi[8] = { +#include "base2.h" +} ; + +/* +r = a * A + b * B +where a = a[0]+256*a[1]+...+256^31 a[31]. +and b = b[0]+256*b[1]+...+256^31 b[31]. +B is the Ed25519 base point (x,4/5) with x positive. +*/ + +static inline void ge_double_scalarmult_vartime(ge_p2 *r,const unsigned char *a,const ge_p3 *A,const unsigned char *b) +{ + signed char aslide[256]; + signed char bslide[256]; + ge_cached Ai[8]; /* A,3A,5A,7A,9A,11A,13A,15A */ + ge_p1p1 t; + ge_p3 u; + ge_p3 A2; + int i; + + slide(aslide,a); + slide(bslide,b); + + ge_p3_to_cached(&Ai[0],A); + ge_p3_dbl(&t,A); ge_p1p1_to_p3(&A2,&t); + ge_add(&t,&A2,&Ai[0]); ge_p1p1_to_p3(&u,&t); ge_p3_to_cached(&Ai[1],&u); + ge_add(&t,&A2,&Ai[1]); ge_p1p1_to_p3(&u,&t); ge_p3_to_cached(&Ai[2],&u); + ge_add(&t,&A2,&Ai[2]); ge_p1p1_to_p3(&u,&t); ge_p3_to_cached(&Ai[3],&u); + ge_add(&t,&A2,&Ai[3]); ge_p1p1_to_p3(&u,&t); ge_p3_to_cached(&Ai[4],&u); + ge_add(&t,&A2,&Ai[4]); ge_p1p1_to_p3(&u,&t); ge_p3_to_cached(&Ai[5],&u); + ge_add(&t,&A2,&Ai[5]); ge_p1p1_to_p3(&u,&t); ge_p3_to_cached(&Ai[6],&u); + ge_add(&t,&A2,&Ai[6]); ge_p1p1_to_p3(&u,&t); ge_p3_to_cached(&Ai[7],&u); + + ge_p2_0(r); + + for (i = 255;i >= 0;--i) { + if (aslide[i] || bslide[i]) break; + } + + for (;i >= 0;--i) { + ge_p2_dbl(&t,r); + + if (aslide[i] > 0) { + ge_p1p1_to_p3(&u,&t); + ge_add(&t,&u,&Ai[aslide[i]/2]); + } else if (aslide[i] < 0) { + ge_p1p1_to_p3(&u,&t); + ge_sub(&t,&u,&Ai[(-aslide[i])/2]); + } + + if (bslide[i] > 0) { + ge_p1p1_to_p3(&u,&t); + ge_madd(&t,&u,&Bi[bslide[i]/2]); + } else if (bslide[i] < 0) { + ge_p1p1_to_p3(&u,&t); + ge_msub(&t,&u,&Bi[(-bslide[i])/2]); + } + + ge_p1p1_to_p2(r,&t); + } +} diff --git a/bundled/cbits/ref10/ge_frombytes.c b/bundled/cbits/ref10/ge_frombytes.c new file mode 100644 index 0000000..b675bab --- /dev/null +++ b/bundled/cbits/ref10/ge_frombytes.c @@ -0,0 +1,50 @@ +#include "ge.h" + +static const fe d = { +#include "d.h" +} ; + +static const fe sqrtm1 = { +#include "sqrtm1.h" +} ; + +static inline int ge_frombytes_negate_vartime(ge_p3 *h,const unsigned char *s) +{ + fe u; + fe v; + fe v3; + fe vxx; + fe check; + + fe_frombytes(h->Y,s); + fe_1(h->Z); + fe_sq(u,h->Y); + fe_mul(v,u,d); + fe_sub(u,u,h->Z); /* u = y^2-1 */ + fe_add(v,v,h->Z); /* v = dy^2+1 */ + + fe_sq(v3,v); + fe_mul(v3,v3,v); /* v3 = v^3 */ + fe_sq(h->X,v3); + fe_mul(h->X,h->X,v); + fe_mul(h->X,h->X,u); /* x = uv^7 */ + + fe_pow22523(h->X,h->X); /* x = (uv^7)^((q-5)/8) */ + fe_mul(h->X,h->X,v3); + fe_mul(h->X,h->X,u); /* x = uv^3(uv^7)^((q-5)/8) */ + + fe_sq(vxx,h->X); + fe_mul(vxx,vxx,v); + fe_sub(check,vxx,u); /* vx^2-u */ + if (fe_isnonzero(check)) { + fe_add(check,vxx,u); /* vx^2+u */ + if (fe_isnonzero(check)) return -1; + fe_mul(h->X,h->X,sqrtm1); + } + + if (fe_isnegative(h->X) == (s[31] >> 7)) + fe_neg(h->X,h->X); + + fe_mul(h->T,h->X,h->Y); + return 0; +} diff --git a/bundled/cbits/ref10/ge_madd.c b/bundled/cbits/ref10/ge_madd.c new file mode 100644 index 0000000..fa39f44 --- /dev/null +++ b/bundled/cbits/ref10/ge_madd.c @@ -0,0 +1,11 @@ +#include "ge.h" + +/* +r = p + q +*/ + +static inline void ge_madd(ge_p1p1 *r,const ge_p3 *p,const ge_precomp *q) +{ + fe t0; +#include "ge_madd.h" +} diff --git a/bundled/cbits/ref10/ge_msub.c b/bundled/cbits/ref10/ge_msub.c new file mode 100644 index 0000000..1de6fa1 --- /dev/null +++ b/bundled/cbits/ref10/ge_msub.c @@ -0,0 +1,11 @@ +#include "ge.h" + +/* +r = p - q +*/ + +static inline void ge_msub(ge_p1p1 *r,const ge_p3 *p,const ge_precomp *q) +{ + fe t0; +#include "ge_msub.h" +} diff --git a/bundled/cbits/ref10/ge_p1p1_to_p2.c b/bundled/cbits/ref10/ge_p1p1_to_p2.c new file mode 100644 index 0000000..f4b52bd --- /dev/null +++ b/bundled/cbits/ref10/ge_p1p1_to_p2.c @@ -0,0 +1,12 @@ +#include "ge.h" + +/* +r = p +*/ + +static inline void ge_p1p1_to_p2(ge_p2 *r,const ge_p1p1 *p) +{ + fe_mul(r->X,p->X,p->T); + fe_mul(r->Y,p->Y,p->Z); + fe_mul(r->Z,p->Z,p->T); +} diff --git a/bundled/cbits/ref10/ge_p1p1_to_p3.c b/bundled/cbits/ref10/ge_p1p1_to_p3.c new file mode 100644 index 0000000..0c70fc5 --- /dev/null +++ b/bundled/cbits/ref10/ge_p1p1_to_p3.c @@ -0,0 +1,13 @@ +#include "ge.h" + +/* +r = p +*/ + +static inline void ge_p1p1_to_p3(ge_p3 *r,const ge_p1p1 *p) +{ + fe_mul(r->X,p->X,p->T); + fe_mul(r->Y,p->Y,p->Z); + fe_mul(r->Z,p->Z,p->T); + fe_mul(r->T,p->X,p->Y); +} diff --git a/bundled/cbits/ref10/ge_p2_0.c b/bundled/cbits/ref10/ge_p2_0.c new file mode 100644 index 0000000..e59fffe --- /dev/null +++ b/bundled/cbits/ref10/ge_p2_0.c @@ -0,0 +1,8 @@ +#include "ge.h" + +static inline void ge_p2_0(ge_p2 *h) +{ + fe_0(h->X); + fe_1(h->Y); + fe_1(h->Z); +} diff --git a/bundled/cbits/ref10/ge_p2_dbl.c b/bundled/cbits/ref10/ge_p2_dbl.c new file mode 100644 index 0000000..a971d78 --- /dev/null +++ b/bundled/cbits/ref10/ge_p2_dbl.c @@ -0,0 +1,11 @@ +#include "ge.h" + +/* +r = 2 * p +*/ + +static inline void ge_p2_dbl(ge_p1p1 *r,const ge_p2 *p) +{ + fe t0; +#include "ge_p2_dbl.h" +} diff --git a/bundled/cbits/ref10/ge_p3_0.c b/bundled/cbits/ref10/ge_p3_0.c new file mode 100644 index 0000000..690a585 --- /dev/null +++ b/bundled/cbits/ref10/ge_p3_0.c @@ -0,0 +1,9 @@ +#include "ge.h" + +static inline void ge_p3_0(ge_p3 *h) +{ + fe_0(h->X); + fe_1(h->Y); + fe_1(h->Z); + fe_0(h->T); +} diff --git a/bundled/cbits/ref10/ge_p3_dbl.c b/bundled/cbits/ref10/ge_p3_dbl.c new file mode 100644 index 0000000..8ad2c20 --- /dev/null +++ b/bundled/cbits/ref10/ge_p3_dbl.c @@ -0,0 +1,12 @@ +#include "ge.h" + +/* +r = 2 * p +*/ + +static inline void ge_p3_dbl(ge_p1p1 *r,const ge_p3 *p) +{ + ge_p2 q; + ge_p3_to_p2(&q,p); + ge_p2_dbl(r,&q); +} diff --git a/bundled/cbits/ref10/ge_p3_to_cached.c b/bundled/cbits/ref10/ge_p3_to_cached.c new file mode 100644 index 0000000..3a079e3 --- /dev/null +++ b/bundled/cbits/ref10/ge_p3_to_cached.c @@ -0,0 +1,17 @@ +#include "ge.h" + +/* +r = p +*/ + +static const fe d2 = { +#include "d2.h" +} ; + +static inline void ge_p3_to_cached(ge_cached *r,const ge_p3 *p) +{ + fe_add(r->YplusX,p->Y,p->X); + fe_sub(r->YminusX,p->Y,p->X); + fe_copy(r->Z,p->Z); + fe_mul(r->T2d,p->T,d2); +} diff --git a/bundled/cbits/ref10/ge_p3_to_p2.c b/bundled/cbits/ref10/ge_p3_to_p2.c new file mode 100644 index 0000000..2b09750 --- /dev/null +++ b/bundled/cbits/ref10/ge_p3_to_p2.c @@ -0,0 +1,12 @@ +#include "ge.h" + +/* +r = p +*/ + +static inline void ge_p3_to_p2(ge_p2 *r,const ge_p3 *p) +{ + fe_copy(r->X,p->X); + fe_copy(r->Y,p->Y); + fe_copy(r->Z,p->Z); +} diff --git a/bundled/cbits/ref10/ge_p3_tobytes.c b/bundled/cbits/ref10/ge_p3_tobytes.c new file mode 100644 index 0000000..db8ad6b --- /dev/null +++ b/bundled/cbits/ref10/ge_p3_tobytes.c @@ -0,0 +1,14 @@ +#include "ge.h" + +static inline void ge_p3_tobytes(unsigned char *s,const ge_p3 *h) +{ + fe recip; + fe x; + fe y; + + fe_invert(recip,h->Z); + fe_mul(x,h->X,recip); + fe_mul(y,h->Y,recip); + fe_tobytes(s,y); + s[31] ^= fe_isnegative(x) << 7; +} diff --git a/bundled/cbits/ref10/ge_precomp_0.c b/bundled/cbits/ref10/ge_precomp_0.c new file mode 100644 index 0000000..95399a7 --- /dev/null +++ b/bundled/cbits/ref10/ge_precomp_0.c @@ -0,0 +1,8 @@ +#include "ge.h" + +static inline void ge_precomp_0(ge_precomp *h) +{ + fe_1(h->yplusx); + fe_1(h->yminusx); + fe_0(h->xy2d); +} diff --git a/bundled/cbits/ref10/ge_scalarmult_base.c b/bundled/cbits/ref10/ge_scalarmult_base.c new file mode 100644 index 0000000..f5f33a4 --- /dev/null +++ b/bundled/cbits/ref10/ge_scalarmult_base.c @@ -0,0 +1,105 @@ +#include "ge.h" +#include "crypto_uint32.h" + +static inline unsigned char equal(signed char b,signed char c) +{ + unsigned char ub = b; + unsigned char uc = c; + unsigned char x = ub ^ uc; /* 0: yes; 1..255: no */ + crypto_uint32 y = x; /* 0: yes; 1..255: no */ + y -= 1; /* 4294967295: yes; 0..254: no */ + y >>= 31; /* 1: yes; 0: no */ + return y; +} + +static inline unsigned char negative(signed char b) +{ + unsigned long long x = b; /* 18446744073709551361..18446744073709551615: yes; 0..255: no */ + x >>= 63; /* 1: yes; 0: no */ + return x; +} + +static inline void cmov(ge_precomp *t,ge_precomp *u,unsigned char b) +{ + fe_cmov(t->yplusx,u->yplusx,b); + fe_cmov(t->yminusx,u->yminusx,b); + fe_cmov(t->xy2d,u->xy2d,b); +} + +/* base[i][j] = (j+1)*256^i*B */ +static ge_precomp base[32][8] = { +#include "base.h" +} ; + +static inline void select_ed25519(ge_precomp *t,int pos,signed char b) +{ + ge_precomp minust; + unsigned char bnegative = negative(b); + unsigned char babs = b - (((-bnegative) & b) << 1); + + ge_precomp_0(t); + cmov(t,&base[pos][0],equal(babs,1)); + cmov(t,&base[pos][1],equal(babs,2)); + cmov(t,&base[pos][2],equal(babs,3)); + cmov(t,&base[pos][3],equal(babs,4)); + cmov(t,&base[pos][4],equal(babs,5)); + cmov(t,&base[pos][5],equal(babs,6)); + cmov(t,&base[pos][6],equal(babs,7)); + cmov(t,&base[pos][7],equal(babs,8)); + fe_copy(minust.yplusx,t->yminusx); + fe_copy(minust.yminusx,t->yplusx); + fe_neg(minust.xy2d,t->xy2d); + cmov(t,&minust,bnegative); +} + +/* +h = a * B +where a = a[0]+256*a[1]+...+256^31 a[31] +B is the Ed25519 base point (x,4/5) with x positive. + +Preconditions: + a[31] <= 127 +*/ + +static inline void ge_scalarmult_base(ge_p3 *h,const unsigned char *a) +{ + signed char e[64]; + signed char carry; + ge_p1p1 r; + ge_p2 s; + ge_precomp t; + int i; + + for (i = 0;i < 32;++i) { + e[2 * i + 0] = (a[i] >> 0) & 15; + e[2 * i + 1] = (a[i] >> 4) & 15; + } + /* each e[i] is between 0 and 15 */ + /* e[63] is between 0 and 7 */ + + carry = 0; + for (i = 0;i < 63;++i) { + e[i] += carry; + carry = e[i] + 8; + carry >>= 4; + e[i] -= carry << 4; + } + e[63] += carry; + /* each e[i] is between -8 and 8 */ + + ge_p3_0(h); + for (i = 1;i < 64;i += 2) { + select_ed25519(&t,i / 2,e[i]); + ge_madd(&r,h,&t); ge_p1p1_to_p3(h,&r); + } + + ge_p3_dbl(&r,h); ge_p1p1_to_p2(&s,&r); + ge_p2_dbl(&r,&s); ge_p1p1_to_p2(&s,&r); + ge_p2_dbl(&r,&s); ge_p1p1_to_p2(&s,&r); + ge_p2_dbl(&r,&s); ge_p1p1_to_p3(h,&r); + + for (i = 0;i < 64;i += 2) { + select_ed25519(&t,i / 2,e[i]); + ge_madd(&r,h,&t); ge_p1p1_to_p3(h,&r); + } +} diff --git a/bundled/cbits/ref10/ge_sub.c b/bundled/cbits/ref10/ge_sub.c new file mode 100644 index 0000000..c7adcee --- /dev/null +++ b/bundled/cbits/ref10/ge_sub.c @@ -0,0 +1,11 @@ +#include "ge.h" + +/* +r = p - q +*/ + +static inline void ge_sub(ge_p1p1 *r,const ge_p3 *p,const ge_cached *q) +{ + fe t0; +#include "ge_sub.h" +} diff --git a/bundled/cbits/ref10/ge_tobytes.c b/bundled/cbits/ref10/ge_tobytes.c new file mode 100644 index 0000000..344679d --- /dev/null +++ b/bundled/cbits/ref10/ge_tobytes.c @@ -0,0 +1,14 @@ +#include "ge.h" + +static inline void ge_tobytes(unsigned char *s,const ge_p2 *h) +{ + fe recip; + fe x; + fe y; + + fe_invert(recip,h->Z); + fe_mul(x,h->X,recip); + fe_mul(y,h->Y,recip); + fe_tobytes(s,y); + s[31] ^= fe_isnegative(x) << 7; +} diff --git a/bundled/cbits/ref10/include/api.h b/bundled/cbits/ref10/include/api.h new file mode 100644 index 0000000..352240c --- /dev/null +++ b/bundled/cbits/ref10/include/api.h @@ -0,0 +1,3 @@ +#define CRYPTO_SECRETKEYBYTES 64 +#define CRYPTO_PUBLICKEYBYTES 32 +#define CRYPTO_BYTES 64 diff --git a/bundled/cbits/ref10/include/base.h b/bundled/cbits/ref10/include/base.h new file mode 100644 index 0000000..573bd8a --- /dev/null +++ b/bundled/cbits/ref10/include/base.h @@ -0,0 +1,1344 @@ +{ + { + { 25967493,-14356035,29566456,3660896,-12694345,4014787,27544626,-11754271,-6079156,2047605 }, + { -12545711,934262,-2722910,3049990,-727428,9406986,12720692,5043384,19500929,-15469378 }, + { -8738181,4489570,9688441,-14785194,10184609,-12363380,29287919,11864899,-24514362,-4438546 }, + }, + { + { -12815894,-12976347,-21581243,11784320,-25355658,-2750717,-11717903,-3814571,-358445,-10211303 }, + { -21703237,6903825,27185491,6451973,-29577724,-9554005,-15616551,11189268,-26829678,-5319081 }, + { 26966642,11152617,32442495,15396054,14353839,-12752335,-3128826,-9541118,-15472047,-4166697 }, + }, + { + { 15636291,-9688557,24204773,-7912398,616977,-16685262,27787600,-14772189,28944400,-1550024 }, + { 16568933,4717097,-11556148,-1102322,15682896,-11807043,16354577,-11775962,7689662,11199574 }, + { 30464156,-5976125,-11779434,-15670865,23220365,15915852,7512774,10017326,-17749093,-9920357 }, + }, + { + { -17036878,13921892,10945806,-6033431,27105052,-16084379,-28926210,15006023,3284568,-6276540 }, + { 23599295,-8306047,-11193664,-7687416,13236774,10506355,7464579,9656445,13059162,10374397 }, + { 7798556,16710257,3033922,2874086,28997861,2835604,32406664,-3839045,-641708,-101325 }, + }, + { + { 10861363,11473154,27284546,1981175,-30064349,12577861,32867885,14515107,-15438304,10819380 }, + { 4708026,6336745,20377586,9066809,-11272109,6594696,-25653668,12483688,-12668491,5581306 }, + { 19563160,16186464,-29386857,4097519,10237984,-4348115,28542350,13850243,-23678021,-15815942 }, + }, + { + { -15371964,-12862754,32573250,4720197,-26436522,5875511,-19188627,-15224819,-9818940,-12085777 }, + { -8549212,109983,15149363,2178705,22900618,4543417,3044240,-15689887,1762328,14866737 }, + { -18199695,-15951423,-10473290,1707278,-17185920,3916101,-28236412,3959421,27914454,4383652 }, + }, + { + { 5153746,9909285,1723747,-2777874,30523605,5516873,19480852,5230134,-23952439,-15175766 }, + { -30269007,-3463509,7665486,10083793,28475525,1649722,20654025,16520125,30598449,7715701 }, + { 28881845,14381568,9657904,3680757,-20181635,7843316,-31400660,1370708,29794553,-1409300 }, + }, + { + { 14499471,-2729599,-33191113,-4254652,28494862,14271267,30290735,10876454,-33154098,2381726 }, + { -7195431,-2655363,-14730155,462251,-27724326,3941372,-6236617,3696005,-32300832,15351955 }, + { 27431194,8222322,16448760,-3907995,-18707002,11938355,-32961401,-2970515,29551813,10109425 }, + }, +}, +{ + { + { -13657040,-13155431,-31283750,11777098,21447386,6519384,-2378284,-1627556,10092783,-4764171 }, + { 27939166,14210322,4677035,16277044,-22964462,-12398139,-32508754,12005538,-17810127,12803510 }, + { 17228999,-15661624,-1233527,300140,-1224870,-11714777,30364213,-9038194,18016357,4397660 }, + }, + { + { -10958843,-7690207,4776341,-14954238,27850028,-15602212,-26619106,14544525,-17477504,982639 }, + { 29253598,15796703,-2863982,-9908884,10057023,3163536,7332899,-4120128,-21047696,9934963 }, + { 5793303,16271923,-24131614,-10116404,29188560,1206517,-14747930,4559895,-30123922,-10897950 }, + }, + { + { -27643952,-11493006,16282657,-11036493,28414021,-15012264,24191034,4541697,-13338309,5500568 }, + { 12650548,-1497113,9052871,11355358,-17680037,-8400164,-17430592,12264343,10874051,13524335 }, + { 25556948,-3045990,714651,2510400,23394682,-10415330,33119038,5080568,-22528059,5376628 }, + }, + { + { -26088264,-4011052,-17013699,-3537628,-6726793,1920897,-22321305,-9447443,4535768,1569007 }, + { -2255422,14606630,-21692440,-8039818,28430649,8775819,-30494562,3044290,31848280,12543772 }, + { -22028579,2943893,-31857513,6777306,13784462,-4292203,-27377195,-2062731,7718482,14474653 }, + }, + { + { 2385315,2454213,-22631320,46603,-4437935,-15680415,656965,-7236665,24316168,-5253567 }, + { 13741529,10911568,-33233417,-8603737,-20177830,-1033297,33040651,-13424532,-20729456,8321686 }, + { 21060490,-2212744,15712757,-4336099,1639040,10656336,23845965,-11874838,-9984458,608372 }, + }, + { + { -13672732,-15087586,-10889693,-7557059,-6036909,11305547,1123968,-6780577,27229399,23887 }, + { -23244140,-294205,-11744728,14712571,-29465699,-2029617,12797024,-6440308,-1633405,16678954 }, + { -29500620,4770662,-16054387,14001338,7830047,9564805,-1508144,-4795045,-17169265,4904953 }, + }, + { + { 24059557,14617003,19037157,-15039908,19766093,-14906429,5169211,16191880,2128236,-4326833 }, + { -16981152,4124966,-8540610,-10653797,30336522,-14105247,-29806336,916033,-6882542,-2986532 }, + { -22630907,12419372,-7134229,-7473371,-16478904,16739175,285431,2763829,15736322,4143876 }, + }, + { + { 2379352,11839345,-4110402,-5988665,11274298,794957,212801,-14594663,23527084,-16458268 }, + { 33431127,-11130478,-17838966,-15626900,8909499,8376530,-32625340,4087881,-15188911,-14416214 }, + { 1767683,7197987,-13205226,-2022635,-13091350,448826,5799055,4357868,-4774191,-16323038 }, + }, +}, +{ + { + { 6721966,13833823,-23523388,-1551314,26354293,-11863321,23365147,-3949732,7390890,2759800 }, + { 4409041,2052381,23373853,10530217,7676779,-12885954,21302353,-4264057,1244380,-12919645 }, + { -4421239,7169619,4982368,-2957590,30256825,-2777540,14086413,9208236,15886429,16489664 }, + }, + { + { 1996075,10375649,14346367,13311202,-6874135,-16438411,-13693198,398369,-30606455,-712933 }, + { -25307465,9795880,-2777414,14878809,-33531835,14780363,13348553,12076947,-30836462,5113182 }, + { -17770784,11797796,31950843,13929123,-25888302,12288344,-30341101,-7336386,13847711,5387222 }, + }, + { + { -18582163,-3416217,17824843,-2340966,22744343,-10442611,8763061,3617786,-19600662,10370991 }, + { 20246567,-14369378,22358229,-543712,18507283,-10413996,14554437,-8746092,32232924,16763880 }, + { 9648505,10094563,26416693,14745928,-30374318,-6472621,11094161,15689506,3140038,-16510092 }, + }, + { + { -16160072,5472695,31895588,4744994,8823515,10365685,-27224800,9448613,-28774454,366295 }, + { 19153450,11523972,-11096490,-6503142,-24647631,5420647,28344573,8041113,719605,11671788 }, + { 8678025,2694440,-6808014,2517372,4964326,11152271,-15432916,-15266516,27000813,-10195553 }, + }, + { + { -15157904,7134312,8639287,-2814877,-7235688,10421742,564065,5336097,6750977,-14521026 }, + { 11836410,-3979488,26297894,16080799,23455045,15735944,1695823,-8819122,8169720,16220347 }, + { -18115838,8653647,17578566,-6092619,-8025777,-16012763,-11144307,-2627664,-5990708,-14166033 }, + }, + { + { -23308498,-10968312,15213228,-10081214,-30853605,-11050004,27884329,2847284,2655861,1738395 }, + { -27537433,-14253021,-25336301,-8002780,-9370762,8129821,21651608,-3239336,-19087449,-11005278 }, + { 1533110,3437855,23735889,459276,29970501,11335377,26030092,5821408,10478196,8544890 }, + }, + { + { 32173121,-16129311,24896207,3921497,22579056,-3410854,19270449,12217473,17789017,-3395995 }, + { -30552961,-2228401,-15578829,-10147201,13243889,517024,15479401,-3853233,30460520,1052596 }, + { -11614875,13323618,32618793,8175907,-15230173,12596687,27491595,-4612359,3179268,-9478891 }, + }, + { + { 31947069,-14366651,-4640583,-15339921,-15125977,-6039709,-14756777,-16411740,19072640,-9511060 }, + { 11685058,11822410,3158003,-13952594,33402194,-4165066,5977896,-5215017,473099,5040608 }, + { -20290863,8198642,-27410132,11602123,1290375,-2799760,28326862,1721092,-19558642,-3131606 }, + }, +}, +{ + { + { 7881532,10687937,7578723,7738378,-18951012,-2553952,21820786,8076149,-27868496,11538389 }, + { -19935666,3899861,18283497,-6801568,-15728660,-11249211,8754525,7446702,-5676054,5797016 }, + { -11295600,-3793569,-15782110,-7964573,12708869,-8456199,2014099,-9050574,-2369172,-5877341 }, + }, + { + { -22472376,-11568741,-27682020,1146375,18956691,16640559,1192730,-3714199,15123619,10811505 }, + { 14352098,-3419715,-18942044,10822655,32750596,4699007,-70363,15776356,-28886779,-11974553 }, + { -28241164,-8072475,-4978962,-5315317,29416931,1847569,-20654173,-16484855,4714547,-9600655 }, + }, + { + { 15200332,8368572,19679101,15970074,-31872674,1959451,24611599,-4543832,-11745876,12340220 }, + { 12876937,-10480056,33134381,6590940,-6307776,14872440,9613953,8241152,15370987,9608631 }, + { -4143277,-12014408,8446281,-391603,4407738,13629032,-7724868,15866074,-28210621,-8814099 }, + }, + { + { 26660628,-15677655,8393734,358047,-7401291,992988,-23904233,858697,20571223,8420556 }, + { 14620715,13067227,-15447274,8264467,14106269,15080814,33531827,12516406,-21574435,-12476749 }, + { 236881,10476226,57258,-14677024,6472998,2466984,17258519,7256740,8791136,15069930 }, + }, + { + { 1276410,-9371918,22949635,-16322807,-23493039,-5702186,14711875,4874229,-30663140,-2331391 }, + { 5855666,4990204,-13711848,7294284,-7804282,1924647,-1423175,-7912378,-33069337,9234253 }, + { 20590503,-9018988,31529744,-7352666,-2706834,10650548,31559055,-11609587,18979186,13396066 }, + }, + { + { 24474287,4968103,22267082,4407354,24063882,-8325180,-18816887,13594782,33514650,7021958 }, + { -11566906,-6565505,-21365085,15928892,-26158305,4315421,-25948728,-3916677,-21480480,12868082 }, + { -28635013,13504661,19988037,-2132761,21078225,6443208,-21446107,2244500,-12455797,-8089383 }, + }, + { + { -30595528,13793479,-5852820,319136,-25723172,-6263899,33086546,8957937,-15233648,5540521 }, + { -11630176,-11503902,-8119500,-7643073,2620056,1022908,-23710744,-1568984,-16128528,-14962807 }, + { 23152971,775386,27395463,14006635,-9701118,4649512,1689819,892185,-11513277,-15205948 }, + }, + { + { 9770129,9586738,26496094,4324120,1556511,-3550024,27453819,4763127,-19179614,5867134 }, + { -32765025,1927590,31726409,-4753295,23962434,-16019500,27846559,5931263,-29749703,-16108455 }, + { 27461885,-2977536,22380810,1815854,-23033753,-3031938,7283490,-15148073,-19526700,7734629 }, + }, +}, +{ + { + { -8010264,-9590817,-11120403,6196038,29344158,-13430885,7585295,-3176626,18549497,15302069 }, + { -32658337,-6171222,-7672793,-11051681,6258878,13504381,10458790,-6418461,-8872242,8424746 }, + { 24687205,8613276,-30667046,-3233545,1863892,-1830544,19206234,7134917,-11284482,-828919 }, + }, + { + { 11334899,-9218022,8025293,12707519,17523892,-10476071,10243738,-14685461,-5066034,16498837 }, + { 8911542,6887158,-9584260,-6958590,11145641,-9543680,17303925,-14124238,6536641,10543906 }, + { -28946384,15479763,-17466835,568876,-1497683,11223454,-2669190,-16625574,-27235709,8876771 }, + }, + { + { -25742899,-12566864,-15649966,-846607,-33026686,-796288,-33481822,15824474,-604426,-9039817 }, + { 10330056,70051,7957388,-9002667,9764902,15609756,27698697,-4890037,1657394,3084098 }, + { 10477963,-7470260,12119566,-13250805,29016247,-5365589,31280319,14396151,-30233575,15272409 }, + }, + { + { -12288309,3169463,28813183,16658753,25116432,-5630466,-25173957,-12636138,-25014757,1950504 }, + { -26180358,9489187,11053416,-14746161,-31053720,5825630,-8384306,-8767532,15341279,8373727 }, + { 28685821,7759505,-14378516,-12002860,-31971820,4079242,298136,-10232602,-2878207,15190420 }, + }, + { + { -32932876,13806336,-14337485,-15794431,-24004620,10940928,8669718,2742393,-26033313,-6875003 }, + { -1580388,-11729417,-25979658,-11445023,-17411874,-10912854,9291594,-16247779,-12154742,6048605 }, + { -30305315,14843444,1539301,11864366,20201677,1900163,13934231,5128323,11213262,9168384 }, + }, + { + { -26280513,11007847,19408960,-940758,-18592965,-4328580,-5088060,-11105150,20470157,-16398701 }, + { -23136053,9282192,14855179,-15390078,-7362815,-14408560,-22783952,14461608,14042978,5230683 }, + { 29969567,-2741594,-16711867,-8552442,9175486,-2468974,21556951,3506042,-5933891,-12449708 }, + }, + { + { -3144746,8744661,19704003,4581278,-20430686,6830683,-21284170,8971513,-28539189,15326563 }, + { -19464629,10110288,-17262528,-3503892,-23500387,1355669,-15523050,15300988,-20514118,9168260 }, + { -5353335,4488613,-23803248,16314347,7780487,-15638939,-28948358,9601605,33087103,-9011387 }, + }, + { + { -19443170,-15512900,-20797467,-12445323,-29824447,10229461,-27444329,-15000531,-5996870,15664672 }, + { 23294591,-16632613,-22650781,-8470978,27844204,11461195,13099750,-2460356,18151676,13417686 }, + { -24722913,-4176517,-31150679,5988919,-26858785,6685065,1661597,-12551441,15271676,-15452665 }, + }, +}, +{ + { + { 11433042,-13228665,8239631,-5279517,-1985436,-725718,-18698764,2167544,-6921301,-13440182 }, + { -31436171,15575146,30436815,12192228,-22463353,9395379,-9917708,-8638997,12215110,12028277 }, + { 14098400,6555944,23007258,5757252,-15427832,-12950502,30123440,4617780,-16900089,-655628 }, + }, + { + { -4026201,-15240835,11893168,13718664,-14809462,1847385,-15819999,10154009,23973261,-12684474 }, + { -26531820,-3695990,-1908898,2534301,-31870557,-16550355,18341390,-11419951,32013174,-10103539 }, + { -25479301,10876443,-11771086,-14625140,-12369567,1838104,21911214,6354752,4425632,-837822 }, + }, + { + { -10433389,-14612966,22229858,-3091047,-13191166,776729,-17415375,-12020462,4725005,14044970 }, + { 19268650,-7304421,1555349,8692754,-21474059,-9910664,6347390,-1411784,-19522291,-16109756 }, + { -24864089,12986008,-10898878,-5558584,-11312371,-148526,19541418,8180106,9282262,10282508 }, + }, + { + { -26205082,4428547,-8661196,-13194263,4098402,-14165257,15522535,8372215,5542595,-10702683 }, + { -10562541,14895633,26814552,-16673850,-17480754,-2489360,-2781891,6993761,-18093885,10114655 }, + { -20107055,-929418,31422704,10427861,-7110749,6150669,-29091755,-11529146,25953725,-106158 }, + }, + { + { -4234397,-8039292,-9119125,3046000,2101609,-12607294,19390020,6094296,-3315279,12831125 }, + { -15998678,7578152,5310217,14408357,-33548620,-224739,31575954,6326196,7381791,-2421839 }, + { -20902779,3296811,24736065,-16328389,18374254,7318640,6295303,8082724,-15362489,12339664 }, + }, + { + { 27724736,2291157,6088201,-14184798,1792727,5857634,13848414,15768922,25091167,14856294 }, + { -18866652,8331043,24373479,8541013,-701998,-9269457,12927300,-12695493,-22182473,-9012899 }, + { -11423429,-5421590,11632845,3405020,30536730,-11674039,-27260765,13866390,30146206,9142070 }, + }, + { + { 3924129,-15307516,-13817122,-10054960,12291820,-668366,-27702774,9326384,-8237858,4171294 }, + { -15921940,16037937,6713787,16606682,-21612135,2790944,26396185,3731949,345228,-5462949 }, + { -21327538,13448259,25284571,1143661,20614966,-8849387,2031539,-12391231,-16253183,-13582083 }, + }, + { + { 31016211,-16722429,26371392,-14451233,-5027349,14854137,17477601,3842657,28012650,-16405420 }, + { -5075835,9368966,-8562079,-4600902,-15249953,6970560,-9189873,16292057,-8867157,3507940 }, + { 29439664,3537914,23333589,6997794,-17555561,-11018068,-15209202,-15051267,-9164929,6580396 }, + }, +}, +{ + { + { -12185861,-7679788,16438269,10826160,-8696817,-6235611,17860444,-9273846,-2095802,9304567 }, + { 20714564,-4336911,29088195,7406487,11426967,-5095705,14792667,-14608617,5289421,-477127 }, + { -16665533,-10650790,-6160345,-13305760,9192020,-1802462,17271490,12349094,26939669,-3752294 }, + }, + { + { -12889898,9373458,31595848,16374215,21471720,13221525,-27283495,-12348559,-3698806,117887 }, + { 22263325,-6560050,3984570,-11174646,-15114008,-566785,28311253,5358056,-23319780,541964 }, + { 16259219,3261970,2309254,-15534474,-16885711,-4581916,24134070,-16705829,-13337066,-13552195 }, + }, + { + { 9378160,-13140186,-22845982,-12745264,28198281,-7244098,-2399684,-717351,690426,14876244 }, + { 24977353,-314384,-8223969,-13465086,28432343,-1176353,-13068804,-12297348,-22380984,6618999 }, + { -1538174,11685646,12944378,13682314,-24389511,-14413193,8044829,-13817328,32239829,-5652762 }, + }, + { + { -18603066,4762990,-926250,8885304,-28412480,-3187315,9781647,-10350059,32779359,5095274 }, + { -33008130,-5214506,-32264887,-3685216,9460461,-9327423,-24601656,14506724,21639561,-2630236 }, + { -16400943,-13112215,25239338,15531969,3987758,-4499318,-1289502,-6863535,17874574,558605 }, + }, + { + { -13600129,10240081,9171883,16131053,-20869254,9599700,33499487,5080151,2085892,5119761 }, + { -22205145,-2519528,-16381601,414691,-25019550,2170430,30634760,-8363614,-31999993,-5759884 }, + { -6845704,15791202,8550074,-1312654,29928809,-12092256,27534430,-7192145,-22351378,12961482 }, + }, + { + { -24492060,-9570771,10368194,11582341,-23397293,-2245287,16533930,8206996,-30194652,-5159638 }, + { -11121496,-3382234,2307366,6362031,-135455,8868177,-16835630,7031275,7589640,8945490 }, + { -32152748,8917967,6661220,-11677616,-1192060,-15793393,7251489,-11182180,24099109,-14456170 }, + }, + { + { 5019558,-7907470,4244127,-14714356,-26933272,6453165,-19118182,-13289025,-6231896,-10280736 }, + { 10853594,10721687,26480089,5861829,-22995819,1972175,-1866647,-10557898,-3363451,-6441124 }, + { -17002408,5906790,221599,-6563147,7828208,-13248918,24362661,-2008168,-13866408,7421392 }, + }, + { + { 8139927,-6546497,32257646,-5890546,30375719,1886181,-21175108,15441252,28826358,-4123029 }, + { 6267086,9695052,7709135,-16603597,-32869068,-1886135,14795160,-7840124,13746021,-1742048 }, + { 28584902,7787108,-6732942,-15050729,22846041,-7571236,-3181936,-363524,4771362,-8419958 }, + }, +}, +{ + { + { 24949256,6376279,-27466481,-8174608,-18646154,-9930606,33543569,-12141695,3569627,11342593 }, + { 26514989,4740088,27912651,3697550,19331575,-11472339,6809886,4608608,7325975,-14801071 }, + { -11618399,-14554430,-24321212,7655128,-1369274,5214312,-27400540,10258390,-17646694,-8186692 }, + }, + { + { 11431204,15823007,26570245,14329124,18029990,4796082,-31446179,15580664,9280358,-3973687 }, + { -160783,-10326257,-22855316,-4304997,-20861367,-13621002,-32810901,-11181622,-15545091,4387441 }, + { -20799378,12194512,3937617,-5805892,-27154820,9340370,-24513992,8548137,20617071,-7482001 }, + }, + { + { -938825,-3930586,-8714311,16124718,24603125,-6225393,-13775352,-11875822,24345683,10325460 }, + { -19855277,-1568885,-22202708,8714034,14007766,6928528,16318175,-1010689,4766743,3552007 }, + { -21751364,-16730916,1351763,-803421,-4009670,3950935,3217514,14481909,10988822,-3994762 }, + }, + { + { 15564307,-14311570,3101243,5684148,30446780,-8051356,12677127,-6505343,-8295852,13296005 }, + { -9442290,6624296,-30298964,-11913677,-4670981,-2057379,31521204,9614054,-30000824,12074674 }, + { 4771191,-135239,14290749,-13089852,27992298,14998318,-1413936,-1556716,29832613,-16391035 }, + }, + { + { 7064884,-7541174,-19161962,-5067537,-18891269,-2912736,25825242,5293297,-27122660,13101590 }, + { -2298563,2439670,-7466610,1719965,-27267541,-16328445,32512469,-5317593,-30356070,-4190957 }, + { -30006540,10162316,-33180176,3981723,-16482138,-13070044,14413974,9515896,19568978,9628812 }, + }, + { + { 33053803,199357,15894591,1583059,27380243,-4580435,-17838894,-6106839,-6291786,3437740 }, + { -18978877,3884493,19469877,12726490,15913552,13614290,-22961733,70104,7463304,4176122 }, + { -27124001,10659917,11482427,-16070381,12771467,-6635117,-32719404,-5322751,24216882,5944158 }, + }, + { + { 8894125,7450974,-2664149,-9765752,-28080517,-12389115,19345746,14680796,11632993,5847885 }, + { 26942781,-2315317,9129564,-4906607,26024105,11769399,-11518837,6367194,-9727230,4782140 }, + { 19916461,-4828410,-22910704,-11414391,25606324,-5972441,33253853,8220911,6358847,-1873857 }, + }, + { + { 801428,-2081702,16569428,11065167,29875704,96627,7908388,-4480480,-13538503,1387155 }, + { 19646058,5720633,-11416706,12814209,11607948,12749789,14147075,15156355,-21866831,11835260 }, + { 19299512,1155910,28703737,14890794,2925026,7269399,26121523,15467869,-26560550,5052483 }, + }, +}, +{ + { + { -3017432,10058206,1980837,3964243,22160966,12322533,-6431123,-12618185,12228557,-7003677 }, + { 32944382,14922211,-22844894,5188528,21913450,-8719943,4001465,13238564,-6114803,8653815 }, + { 22865569,-4652735,27603668,-12545395,14348958,8234005,24808405,5719875,28483275,2841751 }, + }, + { + { -16420968,-1113305,-327719,-12107856,21886282,-15552774,-1887966,-315658,19932058,-12739203 }, + { -11656086,10087521,-8864888,-5536143,-19278573,-3055912,3999228,13239134,-4777469,-13910208 }, + { 1382174,-11694719,17266790,9194690,-13324356,9720081,20403944,11284705,-14013818,3093230 }, + }, + { + { 16650921,-11037932,-1064178,1570629,-8329746,7352753,-302424,16271225,-24049421,-6691850 }, + { -21911077,-5927941,-4611316,-5560156,-31744103,-10785293,24123614,15193618,-21652117,-16739389 }, + { -9935934,-4289447,-25279823,4372842,2087473,10399484,31870908,14690798,17361620,11864968 }, + }, + { + { -11307610,6210372,13206574,5806320,-29017692,-13967200,-12331205,-7486601,-25578460,-16240689 }, + { 14668462,-12270235,26039039,15305210,25515617,4542480,10453892,6577524,9145645,-6443880 }, + { 5974874,3053895,-9433049,-10385191,-31865124,3225009,-7972642,3936128,-5652273,-3050304 }, + }, + { + { 30625386,-4729400,-25555961,-12792866,-20484575,7695099,17097188,-16303496,-27999779,1803632 }, + { -3553091,9865099,-5228566,4272701,-5673832,-16689700,14911344,12196514,-21405489,7047412 }, + { 20093277,9920966,-11138194,-5343857,13161587,12044805,-32856851,4124601,-32343828,-10257566 }, + }, + { + { -20788824,14084654,-13531713,7842147,19119038,-13822605,4752377,-8714640,-21679658,2288038 }, + { -26819236,-3283715,29965059,3039786,-14473765,2540457,29457502,14625692,-24819617,12570232 }, + { -1063558,-11551823,16920318,12494842,1278292,-5869109,-21159943,-3498680,-11974704,4724943 }, + }, + { + { 17960970,-11775534,-4140968,-9702530,-8876562,-1410617,-12907383,-8659932,-29576300,1903856 }, + { 23134274,-14279132,-10681997,-1611936,20684485,15770816,-12989750,3190296,26955097,14109738 }, + { 15308788,5320727,-30113809,-14318877,22902008,7767164,29425325,-11277562,31960942,11934971 }, + }, + { + { -27395711,8435796,4109644,12222639,-24627868,14818669,20638173,4875028,10491392,1379718 }, + { -13159415,9197841,3875503,-8936108,-1383712,-5879801,33518459,16176658,21432314,12180697 }, + { -11787308,11500838,13787581,-13832590,-22430679,10140205,1465425,12689540,-10301319,-13872883 }, + }, +}, +{ + { + { 5414091,-15386041,-21007664,9643570,12834970,1186149,-2622916,-1342231,26128231,6032912 }, + { -26337395,-13766162,32496025,-13653919,17847801,-12669156,3604025,8316894,-25875034,-10437358 }, + { 3296484,6223048,24680646,-12246460,-23052020,5903205,-8862297,-4639164,12376617,3188849 }, + }, + { + { 29190488,-14659046,27549113,-1183516,3520066,-10697301,32049515,-7309113,-16109234,-9852307 }, + { -14744486,-9309156,735818,-598978,-20407687,-5057904,25246078,-15795669,18640741,-960977 }, + { -6928835,-16430795,10361374,5642961,4910474,12345252,-31638386,-494430,10530747,1053335 }, + }, + { + { -29265967,-14186805,-13538216,-12117373,-19457059,-10655384,-31462369,-2948985,24018831,15026644 }, + { -22592535,-3145277,-2289276,5953843,-13440189,9425631,25310643,13003497,-2314791,-15145616 }, + { -27419985,-603321,-8043984,-1669117,-26092265,13987819,-27297622,187899,-23166419,-2531735 }, + }, + { + { -21744398,-13810475,1844840,5021428,-10434399,-15911473,9716667,16266922,-5070217,726099 }, + { 29370922,-6053998,7334071,-15342259,9385287,2247707,-13661962,-4839461,30007388,-15823341 }, + { -936379,16086691,23751945,-543318,-1167538,-5189036,9137109,730663,9835848,4555336 }, + }, + { + { -23376435,1410446,-22253753,-12899614,30867635,15826977,17693930,544696,-11985298,12422646 }, + { 31117226,-12215734,-13502838,6561947,-9876867,-12757670,-5118685,-4096706,29120153,13924425 }, + { -17400879,-14233209,19675799,-2734756,-11006962,-5858820,-9383939,-11317700,7240931,-237388 }, + }, + { + { -31361739,-11346780,-15007447,-5856218,-22453340,-12152771,1222336,4389483,3293637,-15551743 }, + { -16684801,-14444245,11038544,11054958,-13801175,-3338533,-24319580,7733547,12796905,-6335822 }, + { -8759414,-10817836,-25418864,10783769,-30615557,-9746811,-28253339,3647836,3222231,-11160462 }, + }, + { + { 18606113,1693100,-25448386,-15170272,4112353,10045021,23603893,-2048234,-7550776,2484985 }, + { 9255317,-3131197,-12156162,-1004256,13098013,-9214866,16377220,-2102812,-19802075,-3034702 }, + { -22729289,7496160,-5742199,11329249,19991973,-3347502,-31718148,9936966,-30097688,-10618797 }, + }, + { + { 21878590,-5001297,4338336,13643897,-3036865,13160960,19708896,5415497,-7360503,-4109293 }, + { 27736861,10103576,12500508,8502413,-3413016,-9633558,10436918,-1550276,-23659143,-8132100 }, + { 19492550,-12104365,-29681976,-852630,-3208171,12403437,30066266,8367329,13243957,8709688 }, + }, +}, +{ + { + { 12015105,2801261,28198131,10151021,24818120,-4743133,-11194191,-5645734,5150968,7274186 }, + { 2831366,-12492146,1478975,6122054,23825128,-12733586,31097299,6083058,31021603,-9793610 }, + { -2529932,-2229646,445613,10720828,-13849527,-11505937,-23507731,16354465,15067285,-14147707 }, + }, + { + { 7840942,14037873,-33364863,15934016,-728213,-3642706,21403988,1057586,-19379462,-12403220 }, + { 915865,-16469274,15608285,-8789130,-24357026,6060030,-17371319,8410997,-7220461,16527025 }, + { 32922597,-556987,20336074,-16184568,10903705,-5384487,16957574,52992,23834301,6588044 }, + }, + { + { 32752030,11232950,3381995,-8714866,22652988,-10744103,17159699,16689107,-20314580,-1305992 }, + { -4689649,9166776,-25710296,-10847306,11576752,12733943,7924251,-2752281,1976123,-7249027 }, + { 21251222,16309901,-2983015,-6783122,30810597,12967303,156041,-3371252,12331345,-8237197 }, + }, + { + { 8651614,-4477032,-16085636,-4996994,13002507,2950805,29054427,-5106970,10008136,-4667901 }, + { 31486080,15114593,-14261250,12951354,14369431,-7387845,16347321,-13662089,8684155,-10532952 }, + { 19443825,11385320,24468943,-9659068,-23919258,2187569,-26263207,-6086921,31316348,14219878 }, + }, + { + { -28594490,1193785,32245219,11392485,31092169,15722801,27146014,6992409,29126555,9207390 }, + { 32382935,1110093,18477781,11028262,-27411763,-7548111,-4980517,10843782,-7957600,-14435730 }, + { 2814918,7836403,27519878,-7868156,-20894015,-11553689,-21494559,8550130,28346258,1994730 }, + }, + { + { -19578299,8085545,-14000519,-3948622,2785838,-16231307,-19516951,7174894,22628102,8115180 }, + { -30405132,955511,-11133838,-15078069,-32447087,-13278079,-25651578,3317160,-9943017,930272 }, + { -15303681,-6833769,28856490,1357446,23421993,1057177,24091212,-1388970,-22765376,-10650715 }, + }, + { + { -22751231,-5303997,-12907607,-12768866,-15811511,-7797053,-14839018,-16554220,-1867018,8398970 }, + { -31969310,2106403,-4736360,1362501,12813763,16200670,22981545,-6291273,18009408,-15772772 }, + { -17220923,-9545221,-27784654,14166835,29815394,7444469,29551787,-3727419,19288549,1325865 }, + }, + { + { 15100157,-15835752,-23923978,-1005098,-26450192,15509408,12376730,-3479146,33166107,-8042750 }, + { 20909231,13023121,-9209752,16251778,-5778415,-8094914,12412151,10018715,2213263,-13878373 }, + { 32529814,-11074689,30361439,-16689753,-9135940,1513226,22922121,6382134,-5766928,8371348 }, + }, +}, +{ + { + { 9923462,11271500,12616794,3544722,-29998368,-1721626,12891687,-8193132,-26442943,10486144 }, + { -22597207,-7012665,8587003,-8257861,4084309,-12970062,361726,2610596,-23921530,-11455195 }, + { 5408411,-1136691,-4969122,10561668,24145918,14240566,31319731,-4235541,19985175,-3436086 }, + }, + { + { -13994457,16616821,14549246,3341099,32155958,13648976,-17577068,8849297,65030,8370684 }, + { -8320926,-12049626,31204563,5839400,-20627288,-1057277,-19442942,6922164,12743482,-9800518 }, + { -2361371,12678785,28815050,4759974,-23893047,4884717,23783145,11038569,18800704,255233 }, + }, + { + { -5269658,-1773886,13957886,7990715,23132995,728773,13393847,9066957,19258688,-14753793 }, + { -2936654,-10827535,-10432089,14516793,-3640786,4372541,-31934921,2209390,-1524053,2055794 }, + { 580882,16705327,5468415,-2683018,-30926419,-14696000,-7203346,-8994389,-30021019,7394435 }, + }, + { + { 23838809,1822728,-15738443,15242727,8318092,-3733104,-21672180,-3492205,-4821741,14799921 }, + { 13345610,9759151,3371034,-16137791,16353039,8577942,31129804,13496856,-9056018,7402518 }, + { 2286874,-4435931,-20042458,-2008336,-13696227,5038122,11006906,-15760352,8205061,1607563 }, + }, + { + { 14414086,-8002132,3331830,-3208217,22249151,-5594188,18364661,-2906958,30019587,-9029278 }, + { -27688051,1585953,-10775053,931069,-29120221,-11002319,-14410829,12029093,9944378,8024 }, + { 4368715,-3709630,29874200,-15022983,-20230386,-11410704,-16114594,-999085,-8142388,5640030 }, + }, + { + { 10299610,13746483,11661824,16234854,7630238,5998374,9809887,-16694564,15219798,-14327783 }, + { 27425505,-5719081,3055006,10660664,23458024,595578,-15398605,-1173195,-18342183,9742717 }, + { 6744077,2427284,26042789,2720740,-847906,1118974,32324614,7406442,12420155,1994844 }, + }, + { + { 14012521,-5024720,-18384453,-9578469,-26485342,-3936439,-13033478,-10909803,24319929,-6446333 }, + { 16412690,-4507367,10772641,15929391,-17068788,-4658621,10555945,-10484049,-30102368,-4739048 }, + { 22397382,-7767684,-9293161,-12792868,17166287,-9755136,-27333065,6199366,21880021,-12250760 }, + }, + { + { -4283307,5368523,-31117018,8163389,-30323063,3209128,16557151,8890729,8840445,4957760 }, + { -15447727,709327,-6919446,-10870178,-29777922,6522332,-21720181,12130072,-14796503,5005757 }, + { -2114751,-14308128,23019042,15765735,-25269683,6002752,10183197,-13239326,-16395286,-2176112 }, + }, +}, +{ + { + { -19025756,1632005,13466291,-7995100,-23640451,16573537,-32013908,-3057104,22208662,2000468 }, + { 3065073,-1412761,-25598674,-361432,-17683065,-5703415,-8164212,11248527,-3691214,-7414184 }, + { 10379208,-6045554,8877319,1473647,-29291284,-12507580,16690915,2553332,-3132688,16400289 }, + }, + { + { 15716668,1254266,-18472690,7446274,-8448918,6344164,-22097271,-7285580,26894937,9132066 }, + { 24158887,12938817,11085297,-8177598,-28063478,-4457083,-30576463,64452,-6817084,-2692882 }, + { 13488534,7794716,22236231,5989356,25426474,-12578208,2350710,-3418511,-4688006,2364226 }, + }, + { + { 16335052,9132434,25640582,6678888,1725628,8517937,-11807024,-11697457,15445875,-7798101 }, + { 29004207,-7867081,28661402,-640412,-12794003,-7943086,31863255,-4135540,-278050,-15759279 }, + { -6122061,-14866665,-28614905,14569919,-10857999,-3591829,10343412,-6976290,-29828287,-10815811 }, + }, + { + { 27081650,3463984,14099042,-4517604,1616303,-6205604,29542636,15372179,17293797,960709 }, + { 20263915,11434237,-5765435,11236810,13505955,-10857102,-16111345,6493122,-19384511,7639714 }, + { -2830798,-14839232,25403038,-8215196,-8317012,-16173699,18006287,-16043750,29994677,-15808121 }, + }, + { + { 9769828,5202651,-24157398,-13631392,-28051003,-11561624,-24613141,-13860782,-31184575,709464 }, + { 12286395,13076066,-21775189,-1176622,-25003198,4057652,-32018128,-8890874,16102007,13205847 }, + { 13733362,5599946,10557076,3195751,-5557991,8536970,-25540170,8525972,10151379,10394400 }, + }, + { + { 4024660,-16137551,22436262,12276534,-9099015,-2686099,19698229,11743039,-33302334,8934414 }, + { -15879800,-4525240,-8580747,-2934061,14634845,-698278,-9449077,3137094,-11536886,11721158 }, + { 17555939,-5013938,8268606,2331751,-22738815,9761013,9319229,8835153,-9205489,-1280045 }, + }, + { + { -461409,-7830014,20614118,16688288,-7514766,-4807119,22300304,505429,6108462,-6183415 }, + { -5070281,12367917,-30663534,3234473,32617080,-8422642,29880583,-13483331,-26898490,-7867459 }, + { -31975283,5726539,26934134,10237677,-3173717,-605053,24199304,3795095,7592688,-14992079 }, + }, + { + { 21594432,-14964228,17466408,-4077222,32537084,2739898,6407723,12018833,-28256052,4298412 }, + { -20650503,-11961496,-27236275,570498,3767144,-1717540,13891942,-1569194,13717174,10805743 }, + { -14676630,-15644296,15287174,11927123,24177847,-8175568,-796431,14860609,-26938930,-5863836 }, + }, +}, +{ + { + { 12962541,5311799,-10060768,11658280,18855286,-7954201,13286263,-12808704,-4381056,9882022 }, + { 18512079,11319350,-20123124,15090309,18818594,5271736,-22727904,3666879,-23967430,-3299429 }, + { -6789020,-3146043,16192429,13241070,15898607,-14206114,-10084880,-6661110,-2403099,5276065 }, + }, + { + { 30169808,-5317648,26306206,-11750859,27814964,7069267,7152851,3684982,1449224,13082861 }, + { 10342826,3098505,2119311,193222,25702612,12233820,23697382,15056736,-21016438,-8202000 }, + { -33150110,3261608,22745853,7948688,19370557,-15177665,-26171976,6482814,-10300080,-11060101 }, + }, + { + { 32869458,-5408545,25609743,15678670,-10687769,-15471071,26112421,2521008,-22664288,6904815 }, + { 29506923,4457497,3377935,-9796444,-30510046,12935080,1561737,3841096,-29003639,-6657642 }, + { 10340844,-6630377,-18656632,-2278430,12621151,-13339055,30878497,-11824370,-25584551,5181966 }, + }, + { + { 25940115,-12658025,17324188,-10307374,-8671468,15029094,24396252,-16450922,-2322852,-12388574 }, + { -21765684,9916823,-1300409,4079498,-1028346,11909559,1782390,12641087,20603771,-6561742 }, + { -18882287,-11673380,24849422,11501709,13161720,-4768874,1925523,11914390,4662781,7820689 }, + }, + { + { 12241050,-425982,8132691,9393934,32846760,-1599620,29749456,12172924,16136752,15264020 }, + { -10349955,-14680563,-8211979,2330220,-17662549,-14545780,10658213,6671822,19012087,3772772 }, + { 3753511,-3421066,10617074,2028709,14841030,-6721664,28718732,-15762884,20527771,12988982 }, + }, + { + { -14822485,-5797269,-3707987,12689773,-898983,-10914866,-24183046,-10564943,3299665,-12424953 }, + { -16777703,-15253301,-9642417,4978983,3308785,8755439,6943197,6461331,-25583147,8991218 }, + { -17226263,1816362,-1673288,-6086439,31783888,-8175991,-32948145,7417950,-30242287,1507265 }, + }, + { + { 29692663,6829891,-10498800,4334896,20945975,-11906496,-28887608,8209391,14606362,-10647073 }, + { -3481570,8707081,32188102,5672294,22096700,1711240,-33020695,9761487,4170404,-2085325 }, + { -11587470,14855945,-4127778,-1531857,-26649089,15084046,22186522,16002000,-14276837,-8400798 }, + }, + { + { -4811456,13761029,-31703877,-2483919,-3312471,7869047,-7113572,-9620092,13240845,10965870 }, + { -7742563,-8256762,-14768334,-13656260,-23232383,12387166,4498947,14147411,29514390,4302863 }, + { -13413405,-12407859,20757302,-13801832,14785143,8976368,-5061276,-2144373,17846988,-13971927 }, + }, +}, +{ + { + { -2244452,-754728,-4597030,-1066309,-6247172,1455299,-21647728,-9214789,-5222701,12650267 }, + { -9906797,-16070310,21134160,12198166,-27064575,708126,387813,13770293,-19134326,10958663 }, + { 22470984,12369526,23446014,-5441109,-21520802,-9698723,-11772496,-11574455,-25083830,4271862 }, + }, + { + { -25169565,-10053642,-19909332,15361595,-5984358,2159192,75375,-4278529,-32526221,8469673 }, + { 15854970,4148314,-8893890,7259002,11666551,13824734,-30531198,2697372,24154791,-9460943 }, + { 15446137,-15806644,29759747,14019369,30811221,-9610191,-31582008,12840104,24913809,9815020 }, + }, + { + { -4709286,-5614269,-31841498,-12288893,-14443537,10799414,-9103676,13438769,18735128,9466238 }, + { 11933045,9281483,5081055,-5183824,-2628162,-4905629,-7727821,-10896103,-22728655,16199064 }, + { 14576810,379472,-26786533,-8317236,-29426508,-10812974,-102766,1876699,30801119,2164795 }, + }, + { + { 15995086,3199873,13672555,13712240,-19378835,-4647646,-13081610,-15496269,-13492807,1268052 }, + { -10290614,-3659039,-3286592,10948818,23037027,3794475,-3470338,-12600221,-17055369,3565904 }, + { 29210088,-9419337,-5919792,-4952785,10834811,-13327726,-16512102,-10820713,-27162222,-14030531 }, + }, + { + { -13161890,15508588,16663704,-8156150,-28349942,9019123,-29183421,-3769423,2244111,-14001979 }, + { -5152875,-3800936,-9306475,-6071583,16243069,14684434,-25673088,-16180800,13491506,4641841 }, + { 10813417,643330,-19188515,-728916,30292062,-16600078,27548447,-7721242,14476989,-12767431 }, + }, + { + { 10292079,9984945,6481436,8279905,-7251514,7032743,27282937,-1644259,-27912810,12651324 }, + { -31185513,-813383,22271204,11835308,10201545,15351028,17099662,3988035,21721536,-3148940 }, + { 10202177,-6545839,-31373232,-9574638,-32150642,-8119683,-12906320,3852694,13216206,14842320 }, + }, + { + { -15815640,-10601066,-6538952,-7258995,-6984659,-6581778,-31500847,13765824,-27434397,9900184 }, + { 14465505,-13833331,-32133984,-14738873,-27443187,12990492,33046193,15796406,-7051866,-8040114 }, + { 30924417,-8279620,6359016,-12816335,16508377,9071735,-25488601,15413635,9524356,-7018878 }, + }, + { + { 12274201,-13175547,32627641,-1785326,6736625,13267305,5237659,-5109483,15663516,4035784 }, + { -2951309,8903985,17349946,601635,-16432815,-4612556,-13732739,-15889334,-22258478,4659091 }, + { -16916263,-4952973,-30393711,-15158821,20774812,15897498,5736189,15026997,-2178256,-13455585 }, + }, +}, +{ + { + { -8858980,-2219056,28571666,-10155518,-474467,-10105698,-3801496,278095,23440562,-290208 }, + { 10226241,-5928702,15139956,120818,-14867693,5218603,32937275,11551483,-16571960,-7442864 }, + { 17932739,-12437276,-24039557,10749060,11316803,7535897,22503767,5561594,-3646624,3898661 }, + }, + { + { 7749907,-969567,-16339731,-16464,-25018111,15122143,-1573531,7152530,21831162,1245233 }, + { 26958459,-14658026,4314586,8346991,-5677764,11960072,-32589295,-620035,-30402091,-16716212 }, + { -12165896,9166947,33491384,13673479,29787085,13096535,6280834,14587357,-22338025,13987525 }, + }, + { + { -24349909,7778775,21116000,15572597,-4833266,-5357778,-4300898,-5124639,-7469781,-2858068 }, + { 9681908,-6737123,-31951644,13591838,-6883821,386950,31622781,6439245,-14581012,4091397 }, + { -8426427,1470727,-28109679,-1596990,3978627,-5123623,-19622683,12092163,29077877,-14741988 }, + }, + { + { 5269168,-6859726,-13230211,-8020715,25932563,1763552,-5606110,-5505881,-20017847,2357889 }, + { 32264008,-15407652,-5387735,-1160093,-2091322,-3946900,23104804,-12869908,5727338,189038 }, + { 14609123,-8954470,-6000566,-16622781,-14577387,-7743898,-26745169,10942115,-25888931,-14884697 }, + }, + { + { 20513500,5557931,-15604613,7829531,26413943,-2019404,-21378968,7471781,13913677,-5137875 }, + { -25574376,11967826,29233242,12948236,-6754465,4713227,-8940970,14059180,12878652,8511905 }, + { -25656801,3393631,-2955415,-7075526,-2250709,9366908,-30223418,6812974,5568676,-3127656 }, + }, + { + { 11630004,12144454,2116339,13606037,27378885,15676917,-17408753,-13504373,-14395196,8070818 }, + { 27117696,-10007378,-31282771,-5570088,1127282,12772488,-29845906,10483306,-11552749,-1028714 }, + { 10637467,-5688064,5674781,1072708,-26343588,-6982302,-1683975,9177853,-27493162,15431203 }, + }, + { + { 20525145,10892566,-12742472,12779443,-29493034,16150075,-28240519,14943142,-15056790,-7935931 }, + { -30024462,5626926,-551567,-9981087,753598,11981191,25244767,-3239766,-3356550,9594024 }, + { -23752644,2636870,-5163910,-10103818,585134,7877383,11345683,-6492290,13352335,-10977084 }, + }, + { + { -1931799,-5407458,3304649,-12884869,17015806,-4877091,-29783850,-7752482,-13215537,-319204 }, + { 20239939,6607058,6203985,3483793,-18386976,-779229,-20723742,15077870,-22750759,14523817 }, + { 27406042,-6041657,27423596,-4497394,4996214,10002360,-28842031,-4545494,-30172742,-4805667 }, + }, +}, +{ + { + { 11374242,12660715,17861383,-12540833,10935568,1099227,-13886076,-9091740,-27727044,11358504 }, + { -12730809,10311867,1510375,10778093,-2119455,-9145702,32676003,11149336,-26123651,4985768 }, + { -19096303,341147,-6197485,-239033,15756973,-8796662,-983043,13794114,-19414307,-15621255 }, + }, + { + { 6490081,11940286,25495923,-7726360,8668373,-8751316,3367603,6970005,-1691065,-9004790 }, + { 1656497,13457317,15370807,6364910,13605745,8362338,-19174622,-5475723,-16796596,-5031438 }, + { -22273315,-13524424,-64685,-4334223,-18605636,-10921968,-20571065,-7007978,-99853,-10237333 }, + }, + { + { 17747465,10039260,19368299,-4050591,-20630635,-16041286,31992683,-15857976,-29260363,-5511971 }, + { 31932027,-4986141,-19612382,16366580,22023614,88450,11371999,-3744247,4882242,-10626905 }, + { 29796507,37186,19818052,10115756,-11829032,3352736,18551198,3272828,-5190932,-4162409 }, + }, + { + { 12501286,4044383,-8612957,-13392385,-32430052,5136599,-19230378,-3529697,330070,-3659409 }, + { 6384877,2899513,17807477,7663917,-2358888,12363165,25366522,-8573892,-271295,12071499 }, + { -8365515,-4042521,25133448,-4517355,-6211027,2265927,-32769618,1936675,-5159697,3829363 }, + }, + { + { 28425966,-5835433,-577090,-4697198,-14217555,6870930,7921550,-6567787,26333140,14267664 }, + { -11067219,11871231,27385719,-10559544,-4585914,-11189312,10004786,-8709488,-21761224,8930324 }, + { -21197785,-16396035,25654216,-1725397,12282012,11008919,1541940,4757911,-26491501,-16408940 }, + }, + { + { 13537262,-7759490,-20604840,10961927,-5922820,-13218065,-13156584,6217254,-15943699,13814990 }, + { -17422573,15157790,18705543,29619,24409717,-260476,27361681,9257833,-1956526,-1776914 }, + { -25045300,-10191966,15366585,15166509,-13105086,8423556,-29171540,12361135,-18685978,4578290 }, + }, + { + { 24579768,3711570,1342322,-11180126,-27005135,14124956,-22544529,14074919,21964432,8235257 }, + { -6528613,-2411497,9442966,-5925588,12025640,-1487420,-2981514,-1669206,13006806,2355433 }, + { -16304899,-13605259,-6632427,-5142349,16974359,-10911083,27202044,1719366,1141648,-12796236 }, + }, + { + { -12863944,-13219986,-8318266,-11018091,-6810145,-4843894,13475066,-3133972,32674895,13715045 }, + { 11423335,-5468059,32344216,8962751,24989809,9241752,-13265253,16086212,-28740881,-15642093 }, + { -1409668,12530728,-6368726,10847387,19531186,-14132160,-11709148,7791794,-27245943,4383347 }, + }, +}, +{ + { + { -28970898,5271447,-1266009,-9736989,-12455236,16732599,-4862407,-4906449,27193557,6245191 }, + { -15193956,5362278,-1783893,2695834,4960227,12840725,23061898,3260492,22510453,8577507 }, + { -12632451,11257346,-32692994,13548177,-721004,10879011,31168030,13952092,-29571492,-3635906 }, + }, + { + { 3877321,-9572739,32416692,5405324,-11004407,-13656635,3759769,11935320,5611860,8164018 }, + { -16275802,14667797,15906460,12155291,-22111149,-9039718,32003002,-8832289,5773085,-8422109 }, + { -23788118,-8254300,1950875,8937633,18686727,16459170,-905725,12376320,31632953,190926 }, + }, + { + { -24593607,-16138885,-8423991,13378746,14162407,6901328,-8288749,4508564,-25341555,-3627528 }, + { 8884438,-5884009,6023974,10104341,-6881569,-4941533,18722941,-14786005,-1672488,827625 }, + { -32720583,-16289296,-32503547,7101210,13354605,2659080,-1800575,-14108036,-24878478,1541286 }, + }, + { + { 2901347,-1117687,3880376,-10059388,-17620940,-3612781,-21802117,-3567481,20456845,-1885033 }, + { 27019610,12299467,-13658288,-1603234,-12861660,-4861471,-19540150,-5016058,29439641,15138866 }, + { 21536104,-6626420,-32447818,-10690208,-22408077,5175814,-5420040,-16361163,7779328,109896 }, + }, + { + { 30279744,14648750,-8044871,6425558,13639621,-743509,28698390,12180118,23177719,-554075 }, + { 26572847,3405927,-31701700,12890905,-19265668,5335866,-6493768,2378492,4439158,-13279347 }, + { -22716706,3489070,-9225266,-332753,18875722,-1140095,14819434,-12731527,-17717757,-5461437 }, + }, + { + { -5056483,16566551,15953661,3767752,-10436499,15627060,-820954,2177225,8550082,-15114165 }, + { -18473302,16596775,-381660,15663611,22860960,15585581,-27844109,-3582739,-23260460,-8428588 }, + { -32480551,15707275,-8205912,-5652081,29464558,2713815,-22725137,15860482,-21902570,1494193 }, + }, + { + { -19562091,-14087393,-25583872,-9299552,13127842,759709,21923482,16529112,8742704,12967017 }, + { -28464899,1553205,32536856,-10473729,-24691605,-406174,-8914625,-2933896,-29903758,15553883 }, + { 21877909,3230008,9881174,10539357,-4797115,2841332,11543572,14513274,19375923,-12647961 }, + }, + { + { 8832269,-14495485,13253511,5137575,5037871,4078777,24880818,-6222716,2862653,9455043 }, + { 29306751,5123106,20245049,-14149889,9592566,8447059,-2077124,-2990080,15511449,4789663 }, + { -20679756,7004547,8824831,-9434977,-4045704,-3750736,-5754762,108893,23513200,16652362 }, + }, +}, +{ + { + { -33256173,4144782,-4476029,-6579123,10770039,-7155542,-6650416,-12936300,-18319198,10212860 }, + { 2756081,8598110,7383731,-6859892,22312759,-1105012,21179801,2600940,-9988298,-12506466 }, + { -24645692,13317462,-30449259,-15653928,21365574,-10869657,11344424,864440,-2499677,-16710063 }, + }, + { + { -26432803,6148329,-17184412,-14474154,18782929,-275997,-22561534,211300,2719757,4940997 }, + { -1323882,3911313,-6948744,14759765,-30027150,7851207,21690126,8518463,26699843,5276295 }, + { -13149873,-6429067,9396249,365013,24703301,-10488939,1321586,149635,-15452774,7159369 }, + }, + { + { 9987780,-3404759,17507962,9505530,9731535,-2165514,22356009,8312176,22477218,-8403385 }, + { 18155857,-16504990,19744716,9006923,15154154,-10538976,24256460,-4864995,-22548173,9334109 }, + { 2986088,-4911893,10776628,-3473844,10620590,-7083203,-21413845,14253545,-22587149,536906 }, + }, + { + { 4377756,8115836,24567078,15495314,11625074,13064599,7390551,10589625,10838060,-15420424 }, + { -19342404,867880,9277171,-3218459,-14431572,-1986443,19295826,-15796950,6378260,699185 }, + { 7895026,4057113,-7081772,-13077756,-17886831,-323126,-716039,15693155,-5045064,-13373962 }, + }, + { + { -7737563,-5869402,-14566319,-7406919,11385654,13201616,31730678,-10962840,-3918636,-9669325 }, + { 10188286,-15770834,-7336361,13427543,22223443,14896287,30743455,7116568,-21786507,5427593 }, + { 696102,13206899,27047647,-10632082,15285305,-9853179,10798490,-4578720,19236243,12477404 }, + }, + { + { -11229439,11243796,-17054270,-8040865,-788228,-8167967,-3897669,11180504,-23169516,7733644 }, + { 17800790,-14036179,-27000429,-11766671,23887827,3149671,23466177,-10538171,10322027,15313801 }, + { 26246234,11968874,32263343,-5468728,6830755,-13323031,-15794704,-101982,-24449242,10890804 }, + }, + { + { -31365647,10271363,-12660625,-6267268,16690207,-13062544,-14982212,16484931,25180797,-5334884 }, + { -586574,10376444,-32586414,-11286356,19801893,10997610,2276632,9482883,316878,13820577 }, + { -9882808,-4510367,-2115506,16457136,-11100081,11674996,30756178,-7515054,30696930,-3712849 }, + }, + { + { 32988917,-9603412,12499366,7910787,-10617257,-11931514,-7342816,-9985397,-32349517,7392473 }, + { -8855661,15927861,9866406,-3649411,-2396914,-16655781,-30409476,-9134995,25112947,-2926644 }, + { -2504044,-436966,25621774,-5678772,15085042,-5479877,-24884878,-13526194,5537438,-13914319 }, + }, +}, +{ + { + { -11225584,2320285,-9584280,10149187,-33444663,5808648,-14876251,-1729667,31234590,6090599 }, + { -9633316,116426,26083934,2897444,-6364437,-2688086,609721,15878753,-6970405,-9034768 }, + { -27757857,247744,-15194774,-9002551,23288161,-10011936,-23869595,6503646,20650474,1804084 }, + }, + { + { -27589786,15456424,8972517,8469608,15640622,4439847,3121995,-10329713,27842616,-202328 }, + { -15306973,2839644,22530074,10026331,4602058,5048462,28248656,5031932,-11375082,12714369 }, + { 20807691,-7270825,29286141,11421711,-27876523,-13868230,-21227475,1035546,-19733229,12796920 }, + }, + { + { 12076899,-14301286,-8785001,-11848922,-25012791,16400684,-17591495,-12899438,3480665,-15182815 }, + { -32361549,5457597,28548107,7833186,7303070,-11953545,-24363064,-15921875,-33374054,2771025 }, + { -21389266,421932,26597266,6860826,22486084,-6737172,-17137485,-4210226,-24552282,15673397 }, + }, + { + { -20184622,2338216,19788685,-9620956,-4001265,-8740893,-20271184,4733254,3727144,-12934448 }, + { 6120119,814863,-11794402,-622716,6812205,-15747771,2019594,7975683,31123697,-10958981 }, + { 30069250,-11435332,30434654,2958439,18399564,-976289,12296869,9204260,-16432438,9648165 }, + }, + { + { 32705432,-1550977,30705658,7451065,-11805606,9631813,3305266,5248604,-26008332,-11377501 }, + { 17219865,2375039,-31570947,-5575615,-19459679,9219903,294711,15298639,2662509,-16297073 }, + { -1172927,-7558695,-4366770,-4287744,-21346413,-8434326,32087529,-1222777,32247248,-14389861 }, + }, + { + { 14312628,1221556,17395390,-8700143,-4945741,-8684635,-28197744,-9637817,-16027623,-13378845 }, + { -1428825,-9678990,-9235681,6549687,-7383069,-468664,23046502,9803137,17597934,2346211 }, + { 18510800,15337574,26171504,981392,-22241552,7827556,-23491134,-11323352,3059833,-11782870 }, + }, + { + { 10141598,6082907,17829293,-1947643,9830092,13613136,-25556636,-5544586,-33502212,3592096 }, + { 33114168,-15889352,-26525686,-13343397,33076705,8716171,1151462,1521897,-982665,-6837803 }, + { -32939165,-4255815,23947181,-324178,-33072974,-12305637,-16637686,3891704,26353178,693168 }, + }, + { + { 30374239,1595580,-16884039,13186931,4600344,406904,9585294,-400668,31375464,14369965 }, + { -14370654,-7772529,1510301,6434173,-18784789,-6262728,32732230,-13108839,17901441,16011505 }, + { 18171223,-11934626,-12500402,15197122,-11038147,-15230035,-19172240,-16046376,8764035,12309598 }, + }, +}, +{ + { + { 5975908,-5243188,-19459362,-9681747,-11541277,14015782,-23665757,1228319,17544096,-10593782 }, + { 5811932,-1715293,3442887,-2269310,-18367348,-8359541,-18044043,-15410127,-5565381,12348900 }, + { -31399660,11407555,25755363,6891399,-3256938,14872274,-24849353,8141295,-10632534,-585479 }, + }, + { + { -12675304,694026,-5076145,13300344,14015258,-14451394,-9698672,-11329050,30944593,1130208 }, + { 8247766,-6710942,-26562381,-7709309,-14401939,-14648910,4652152,2488540,23550156,-271232 }, + { 17294316,-3788438,7026748,15626851,22990044,113481,2267737,-5908146,-408818,-137719 }, + }, + { + { 16091085,-16253926,18599252,7340678,2137637,-1221657,-3364161,14550936,3260525,-7166271 }, + { -4910104,-13332887,18550887,10864893,-16459325,-7291596,-23028869,-13204905,-12748722,2701326 }, + { -8574695,16099415,4629974,-16340524,-20786213,-6005432,-10018363,9276971,11329923,1862132 }, + }, + { + { 14763076,-15903608,-30918270,3689867,3511892,10313526,-21951088,12219231,-9037963,-940300 }, + { 8894987,-3446094,6150753,3013931,301220,15693451,-31981216,-2909717,-15438168,11595570 }, + { 15214962,3537601,-26238722,-14058872,4418657,-15230761,13947276,10730794,-13489462,-4363670 }, + }, + { + { -2538306,7682793,32759013,263109,-29984731,-7955452,-22332124,-10188635,977108,699994 }, + { -12466472,4195084,-9211532,550904,-15565337,12917920,19118110,-439841,-30534533,-14337913 }, + { 31788461,-14507657,4799989,7372237,8808585,-14747943,9408237,-10051775,12493932,-5409317 }, + }, + { + { -25680606,5260744,-19235809,-6284470,-3695942,16566087,27218280,2607121,29375955,6024730 }, + { 842132,-2794693,-4763381,-8722815,26332018,-12405641,11831880,6985184,-9940361,2854096 }, + { -4847262,-7969331,2516242,-5847713,9695691,-7221186,16512645,960770,12121869,16648078 }, + }, + { + { -15218652,14667096,-13336229,2013717,30598287,-464137,-31504922,-7882064,20237806,2838411 }, + { -19288047,4453152,15298546,-16178388,22115043,-15972604,12544294,-13470457,1068881,-12499905 }, + { -9558883,-16518835,33238498,13506958,30505848,-1114596,-8486907,-2630053,12521378,4845654 }, + }, + { + { -28198521,10744108,-2958380,10199664,7759311,-13088600,3409348,-873400,-6482306,-12885870 }, + { -23561822,6230156,-20382013,10655314,-24040585,-11621172,10477734,-1240216,-3113227,13974498 }, + { 12966261,15550616,-32038948,-1615346,21025980,-629444,5642325,7188737,18895762,12629579 }, + }, +}, +{ + { + { 14741879,-14946887,22177208,-11721237,1279741,8058600,11758140,789443,32195181,3895677 }, + { 10758205,15755439,-4509950,9243698,-4879422,6879879,-2204575,-3566119,-8982069,4429647 }, + { -2453894,15725973,-20436342,-10410672,-5803908,-11040220,-7135870,-11642895,18047436,-15281743 }, + }, + { + { -25173001,-11307165,29759956,11776784,-22262383,-15820455,10993114,-12850837,-17620701,-9408468 }, + { 21987233,700364,-24505048,14972008,-7774265,-5718395,32155026,2581431,-29958985,8773375 }, + { -25568350,454463,-13211935,16126715,25240068,8594567,20656846,12017935,-7874389,-13920155 }, + }, + { + { 6028182,6263078,-31011806,-11301710,-818919,2461772,-31841174,-5468042,-1721788,-2776725 }, + { -12278994,16624277,987579,-5922598,32908203,1248608,7719845,-4166698,28408820,6816612 }, + { -10358094,-8237829,19549651,-12169222,22082623,16147817,20613181,13982702,-10339570,5067943 }, + }, + { + { -30505967,-3821767,12074681,13582412,-19877972,2443951,-19719286,12746132,5331210,-10105944 }, + { 30528811,3601899,-1957090,4619785,-27361822,-15436388,24180793,-12570394,27679908,-1648928 }, + { 9402404,-13957065,32834043,10838634,-26580150,-13237195,26653274,-8685565,22611444,-12715406 }, + }, + { + { 22190590,1118029,22736441,15130463,-30460692,-5991321,19189625,-4648942,4854859,6622139 }, + { -8310738,-2953450,-8262579,-3388049,-10401731,-271929,13424426,-3567227,26404409,13001963 }, + { -31241838,-15415700,-2994250,8939346,11562230,-12840670,-26064365,-11621720,-15405155,11020693 }, + }, + { + { 1866042,-7949489,-7898649,-10301010,12483315,13477547,3175636,-12424163,28761762,1406734 }, + { -448555,-1777666,13018551,3194501,-9580420,-11161737,24760585,-4347088,25577411,-13378680 }, + { -24290378,4759345,-690653,-1852816,2066747,10693769,-29595790,9884936,-9368926,4745410 }, + }, + { + { -9141284,6049714,-19531061,-4341411,-31260798,9944276,-15462008,-11311852,10931924,-11931931 }, + { -16561513,14112680,-8012645,4817318,-8040464,-11414606,-22853429,10856641,-20470770,13434654 }, + { 22759489,-10073434,-16766264,-1871422,13637442,-10168091,1765144,-12654326,28445307,-5364710 }, + }, + { + { 29875063,12493613,2795536,-3786330,1710620,15181182,-10195717,-8788675,9074234,1167180 }, + { -26205683,11014233,-9842651,-2635485,-26908120,7532294,-18716888,-9535498,3843903,9367684 }, + { -10969595,-6403711,9591134,9582310,11349256,108879,16235123,8601684,-139197,4242895 }, + }, +}, +{ + { + { 22092954,-13191123,-2042793,-11968512,32186753,-11517388,-6574341,2470660,-27417366,16625501 }, + { -11057722,3042016,13770083,-9257922,584236,-544855,-7770857,2602725,-27351616,14247413 }, + { 6314175,-10264892,-32772502,15957557,-10157730,168750,-8618807,14290061,27108877,-1180880 }, + }, + { + { -8586597,-7170966,13241782,10960156,-32991015,-13794596,33547976,-11058889,-27148451,981874 }, + { 22833440,9293594,-32649448,-13618667,-9136966,14756819,-22928859,-13970780,-10479804,-16197962 }, + { -7768587,3326786,-28111797,10783824,19178761,14905060,22680049,13906969,-15933690,3797899 }, + }, + { + { 21721356,-4212746,-12206123,9310182,-3882239,-13653110,23740224,-2709232,20491983,-8042152 }, + { 9209270,-15135055,-13256557,-6167798,-731016,15289673,25947805,15286587,30997318,-6703063 }, + { 7392032,16618386,23946583,-8039892,-13265164,-1533858,-14197445,-2321576,17649998,-250080 }, + }, + { + { -9301088,-14193827,30609526,-3049543,-25175069,-1283752,-15241566,-9525724,-2233253,7662146 }, + { -17558673,1763594,-33114336,15908610,-30040870,-12174295,7335080,-8472199,-3174674,3440183 }, + { -19889700,-5977008,-24111293,-9688870,10799743,-16571957,40450,-4431835,4862400,1133 }, + }, + { + { -32856209,-7873957,-5422389,14860950,-16319031,7956142,7258061,311861,-30594991,-7379421 }, + { -3773428,-1565936,28985340,7499440,24445838,9325937,29727763,16527196,18278453,15405622 }, + { -4381906,8508652,-19898366,-3674424,-5984453,15149970,-13313598,843523,-21875062,13626197 }, + }, + { + { 2281448,-13487055,-10915418,-2609910,1879358,16164207,-10783882,3953792,13340839,15928663 }, + { 31727126,-7179855,-18437503,-8283652,2875793,-16390330,-25269894,-7014826,-23452306,5964753 }, + { 4100420,-5959452,-17179337,6017714,-18705837,12227141,-26684835,11344144,2538215,-7570755 }, + }, + { + { -9433605,6123113,11159803,-2156608,30016280,14966241,-20474983,1485421,-629256,-15958862 }, + { -26804558,4260919,11851389,9658551,-32017107,16367492,-20205425,-13191288,11659922,-11115118 }, + { 26180396,10015009,-30844224,-8581293,5418197,9480663,2231568,-10170080,33100372,-1306171 }, + }, + { + { 15121113,-5201871,-10389905,15427821,-27509937,-15992507,21670947,4486675,-5931810,-14466380 }, + { 16166486,-9483733,-11104130,6023908,-31926798,-1364923,2340060,-16254968,-10735770,-10039824 }, + { 28042865,-3557089,-12126526,12259706,-3717498,-6945899,6766453,-8689599,18036436,5803270 }, + }, +}, +{ + { + { -817581,6763912,11803561,1585585,10958447,-2671165,23855391,4598332,-6159431,-14117438 }, + { -31031306,-14256194,17332029,-2383520,31312682,-5967183,696309,50292,-20095739,11763584 }, + { -594563,-2514283,-32234153,12643980,12650761,14811489,665117,-12613632,-19773211,-10713562 }, + }, + { + { 30464590,-11262872,-4127476,-12734478,19835327,-7105613,-24396175,2075773,-17020157,992471 }, + { 18357185,-6994433,7766382,16342475,-29324918,411174,14578841,8080033,-11574335,-10601610 }, + { 19598397,10334610,12555054,2555664,18821899,-10339780,21873263,16014234,26224780,16452269 }, + }, + { + { -30223925,5145196,5944548,16385966,3976735,2009897,-11377804,-7618186,-20533829,3698650 }, + { 14187449,3448569,-10636236,-10810935,-22663880,-3433596,7268410,-10890444,27394301,12015369 }, + { 19695761,16087646,28032085,12999827,6817792,11427614,20244189,-1312777,-13259127,-3402461 }, + }, + { + { 30860103,12735208,-1888245,-4699734,-16974906,2256940,-8166013,12298312,-8550524,-10393462 }, + { -5719826,-11245325,-1910649,15569035,26642876,-7587760,-5789354,-15118654,-4976164,12651793 }, + { -2848395,9953421,11531313,-5282879,26895123,-12697089,-13118820,-16517902,9768698,-2533218 }, + }, + { + { -24719459,1894651,-287698,-4704085,15348719,-8156530,32767513,12765450,4940095,10678226 }, + { 18860224,15980149,-18987240,-1562570,-26233012,-11071856,-7843882,13944024,-24372348,16582019 }, + { -15504260,4970268,-29893044,4175593,-20993212,-2199756,-11704054,15444560,-11003761,7989037 }, + }, + { + { 31490452,5568061,-2412803,2182383,-32336847,4531686,-32078269,6200206,-19686113,-14800171 }, + { -17308668,-15879940,-31522777,-2831,-32887382,16375549,8680158,-16371713,28550068,-6857132 }, + { -28126887,-5688091,16837845,-1820458,-6850681,12700016,-30039981,4364038,1155602,5988841 }, + }, + { + { 21890435,-13272907,-12624011,12154349,-7831873,15300496,23148983,-4470481,24618407,8283181 }, + { -33136107,-10512751,9975416,6841041,-31559793,16356536,3070187,-7025928,1466169,10740210 }, + { -1509399,-15488185,-13503385,-10655916,32799044,909394,-13938903,-5779719,-32164649,-15327040 }, + }, + { + { 3960823,-14267803,-28026090,-15918051,-19404858,13146868,15567327,951507,-3260321,-573935 }, + { 24740841,5052253,-30094131,8961361,25877428,6165135,-24368180,14397372,-7380369,-6144105 }, + { -28888365,3510803,-28103278,-1158478,-11238128,-10631454,-15441463,-14453128,-1625486,-6494814 }, + }, +}, +{ + { + { 793299,-9230478,8836302,-6235707,-27360908,-2369593,33152843,-4885251,-9906200,-621852 }, + { 5666233,525582,20782575,-8038419,-24538499,14657740,16099374,1468826,-6171428,-15186581 }, + { -4859255,-3779343,-2917758,-6748019,7778750,11688288,-30404353,-9871238,-1558923,-9863646 }, + }, + { + { 10896332,-7719704,824275,472601,-19460308,3009587,25248958,14783338,-30581476,-15757844 }, + { 10566929,12612572,-31944212,11118703,-12633376,12362879,21752402,8822496,24003793,14264025 }, + { 27713862,-7355973,-11008240,9227530,27050101,2504721,23886875,-13117525,13958495,-5732453 }, + }, + { + { -23481610,4867226,-27247128,3900521,29838369,-8212291,-31889399,-10041781,7340521,-15410068 }, + { 4646514,-8011124,-22766023,-11532654,23184553,8566613,31366726,-1381061,-15066784,-10375192 }, + { -17270517,12723032,-16993061,14878794,21619651,-6197576,27584817,3093888,-8843694,3849921 }, + }, + { + { -9064912,2103172,25561640,-15125738,-5239824,9582958,32477045,-9017955,5002294,-15550259 }, + { -12057553,-11177906,21115585,-13365155,8808712,-12030708,16489530,13378448,-25845716,12741426 }, + { -5946367,10645103,-30911586,15390284,-3286982,-7118677,24306472,15852464,28834118,-7646072 }, + }, + { + { -17335748,-9107057,-24531279,9434953,-8472084,-583362,-13090771,455841,20461858,5491305 }, + { 13669248,-16095482,-12481974,-10203039,-14569770,-11893198,-24995986,11293807,-28588204,-9421832 }, + { 28497928,6272777,-33022994,14470570,8906179,-1225630,18504674,-14165166,29867745,-8795943 }, + }, + { + { -16207023,13517196,-27799630,-13697798,24009064,-6373891,-6367600,-13175392,22853429,-4012011 }, + { 24191378,16712145,-13931797,15217831,14542237,1646131,18603514,-11037887,12876623,-2112447 }, + { 17902668,4518229,-411702,-2829247,26878217,5258055,-12860753,608397,16031844,3723494 }, + }, + { + { -28632773,12763728,-20446446,7577504,33001348,-13017745,17558842,-7872890,23896954,-4314245 }, + { -20005381,-12011952,31520464,605201,2543521,5991821,-2945064,7229064,-9919646,-8826859 }, + { 28816045,298879,-28165016,-15920938,19000928,-1665890,-12680833,-2949325,-18051778,-2082915 }, + }, + { + { 16000882,-344896,3493092,-11447198,-29504595,-13159789,12577740,16041268,-19715240,7847707 }, + { 10151868,10572098,27312476,7922682,14825339,4723128,-32855931,-6519018,-10020567,3852848 }, + { -11430470,15697596,-21121557,-4420647,5386314,15063598,16514493,-15932110,29330899,-15076224 }, + }, +}, +{ + { + { -25499735,-4378794,-15222908,-6901211,16615731,2051784,3303702,15490,-27548796,12314391 }, + { 15683520,-6003043,18109120,-9980648,15337968,-5997823,-16717435,15921866,16103996,-3731215 }, + { -23169824,-10781249,13588192,-1628807,-3798557,-1074929,-19273607,5402699,-29815713,-9841101 }, + }, + { + { 23190676,2384583,-32714340,3462154,-29903655,-1529132,-11266856,8911517,-25205859,2739713 }, + { 21374101,-3554250,-33524649,9874411,15377179,11831242,-33529904,6134907,4931255,11987849 }, + { -7732,-2978858,-16223486,7277597,105524,-322051,-31480539,13861388,-30076310,10117930 }, + }, + { + { -29501170,-10744872,-26163768,13051539,-25625564,5089643,-6325503,6704079,12890019,15728940 }, + { -21972360,-11771379,-951059,-4418840,14704840,2695116,903376,-10428139,12885167,8311031 }, + { -17516482,5352194,10384213,-13811658,7506451,13453191,26423267,4384730,1888765,-5435404 }, + }, + { + { -25817338,-3107312,-13494599,-3182506,30896459,-13921729,-32251644,-12707869,-19464434,-3340243 }, + { -23607977,-2665774,-526091,4651136,5765089,4618330,6092245,14845197,17151279,-9854116 }, + { -24830458,-12733720,-15165978,10367250,-29530908,-265356,22825805,-7087279,-16866484,16176525 }, + }, + { + { -23583256,6564961,20063689,3798228,-4740178,7359225,2006182,-10363426,-28746253,-10197509 }, + { -10626600,-4486402,-13320562,-5125317,3432136,-6393229,23632037,-1940610,32808310,1099883 }, + { 15030977,5768825,-27451236,-2887299,-6427378,-15361371,-15277896,-6809350,2051441,-15225865 }, + }, + { + { -3362323,-7239372,7517890,9824992,23555850,295369,5148398,-14154188,-22686354,16633660 }, + { 4577086,-16752288,13249841,-15304328,19958763,-14537274,18559670,-10759549,8402478,-9864273 }, + { -28406330,-1051581,-26790155,-907698,-17212414,-11030789,9453451,-14980072,17983010,9967138 }, + }, + { + { -25762494,6524722,26585488,9969270,24709298,1220360,-1677990,7806337,17507396,3651560 }, + { -10420457,-4118111,14584639,15971087,-15768321,8861010,26556809,-5574557,-18553322,-11357135 }, + { 2839101,14284142,4029895,3472686,14402957,12689363,-26642121,8459447,-5605463,-7621941 }, + }, + { + { -4839289,-3535444,9744961,2871048,25113978,3187018,-25110813,-849066,17258084,-7977739 }, + { 18164541,-10595176,-17154882,-1542417,19237078,-9745295,23357533,-15217008,26908270,12150756 }, + { -30264870,-7647865,5112249,-7036672,-1499807,-6974257,43168,-5537701,-32302074,16215819 }, + }, +}, +{ + { + { -6898905,9824394,-12304779,-4401089,-31397141,-6276835,32574489,12532905,-7503072,-8675347 }, + { -27343522,-16515468,-27151524,-10722951,946346,16291093,254968,7168080,21676107,-1943028 }, + { 21260961,-8424752,-16831886,-11920822,-23677961,3968121,-3651949,-6215466,-3556191,-7913075 }, + }, + { + { 16544754,13250366,-16804428,15546242,-4583003,12757258,-2462308,-8680336,-18907032,-9662799 }, + { -2415239,-15577728,18312303,4964443,-15272530,-12653564,26820651,16690659,25459437,-4564609 }, + { -25144690,11425020,28423002,-11020557,-6144921,-15826224,9142795,-2391602,-6432418,-1644817 }, + }, + { + { -23104652,6253476,16964147,-3768872,-25113972,-12296437,-27457225,-16344658,6335692,7249989 }, + { -30333227,13979675,7503222,-12368314,-11956721,-4621693,-30272269,2682242,25993170,-12478523 }, + { 4364628,5930691,32304656,-10044554,-8054781,15091131,22857016,-10598955,31820368,15075278 }, + }, + { + { 31879134,-8918693,17258761,90626,-8041836,-4917709,24162788,-9650886,-17970238,12833045 }, + { 19073683,14851414,-24403169,-11860168,7625278,11091125,-19619190,2074449,-9413939,14905377 }, + { 24483667,-11935567,-2518866,-11547418,-1553130,15355506,-25282080,9253129,27628530,-7555480 }, + }, + { + { 17597607,8340603,19355617,552187,26198470,-3176583,4593324,-9157582,-14110875,15297016 }, + { 510886,14337390,-31785257,16638632,6328095,2713355,-20217417,-11864220,8683221,2921426 }, + { 18606791,11874196,27155355,-5281482,-24031742,6265446,-25178240,-1278924,4674690,13890525 }, + }, + { + { 13609624,13069022,-27372361,-13055908,24360586,9592974,14977157,9835105,4389687,288396 }, + { 9922506,-519394,13613107,5883594,-18758345,-434263,-12304062,8317628,23388070,16052080 }, + { 12720016,11937594,-31970060,-5028689,26900120,8561328,-20155687,-11632979,-14754271,-10812892 }, + }, + { + { 15961858,14150409,26716931,-665832,-22794328,13603569,11829573,7467844,-28822128,929275 }, + { 11038231,-11582396,-27310482,-7316562,-10498527,-16307831,-23479533,-9371869,-21393143,2465074 }, + { 20017163,-4323226,27915242,1529148,12396362,15675764,13817261,-9658066,2463391,-4622140 }, + }, + { + { -16358878,-12663911,-12065183,4996454,-1256422,1073572,9583558,12851107,4003896,12673717 }, + { -1731589,-15155870,-3262930,16143082,19294135,13385325,14741514,-9103726,7903886,2348101 }, + { 24536016,-16515207,12715592,-3862155,1511293,10047386,-3842346,-7129159,-28377538,10048127 }, + }, +}, +{ + { + { -12622226,-6204820,30718825,2591312,-10617028,12192840,18873298,-7297090,-32297756,15221632 }, + { -26478122,-11103864,11546244,-1852483,9180880,7656409,-21343950,2095755,29769758,6593415 }, + { -31994208,-2907461,4176912,3264766,12538965,-868111,26312345,-6118678,30958054,8292160 }, + }, + { + { 31429822,-13959116,29173532,15632448,12174511,-2760094,32808831,3977186,26143136,-3148876 }, + { 22648901,1402143,-22799984,13746059,7936347,365344,-8668633,-1674433,-3758243,-2304625 }, + { -15491917,8012313,-2514730,-12702462,-23965846,-10254029,-1612713,-1535569,-16664475,8194478 }, + }, + { + { 27338066,-7507420,-7414224,10140405,-19026427,-6589889,27277191,8855376,28572286,3005164 }, + { 26287124,4821776,25476601,-4145903,-3764513,-15788984,-18008582,1182479,-26094821,-13079595 }, + { -7171154,3178080,23970071,6201893,-17195577,-4489192,-21876275,-13982627,32208683,-1198248 }, + }, + { + { -16657702,2817643,-10286362,14811298,6024667,13349505,-27315504,-10497842,-27672585,-11539858 }, + { 15941029,-9405932,-21367050,8062055,31876073,-238629,-15278393,-1444429,15397331,-4130193 }, + { 8934485,-13485467,-23286397,-13423241,-32446090,14047986,31170398,-1441021,-27505566,15087184 }, + }, + { + { -18357243,-2156491,24524913,-16677868,15520427,-6360776,-15502406,11461896,16788528,-5868942 }, + { -1947386,16013773,21750665,3714552,-17401782,-16055433,-3770287,-10323320,31322514,-11615635 }, + { 21426655,-5650218,-13648287,-5347537,-28812189,-4920970,-18275391,-14621414,13040862,-12112948 }, + }, + { + { 11293895,12478086,-27136401,15083750,-29307421,14748872,14555558,-13417103,1613711,4896935 }, + { -25894883,15323294,-8489791,-8057900,25967126,-13425460,2825960,-4897045,-23971776,-11267415 }, + { -15924766,-5229880,-17443532,6410664,3622847,10243618,20615400,12405433,-23753030,-8436416 }, + }, + { + { -7091295,12556208,-20191352,9025187,-17072479,4333801,4378436,2432030,23097949,-566018 }, + { 4565804,-16025654,20084412,-7842817,1724999,189254,24767264,10103221,-18512313,2424778 }, + { 366633,-11976806,8173090,-6890119,30788634,5745705,-7168678,1344109,-3642553,12412659 }, + }, + { + { -24001791,7690286,14929416,-168257,-32210835,-13412986,24162697,-15326504,-3141501,11179385 }, + { 18289522,-14724954,8056945,16430056,-21729724,7842514,-6001441,-1486897,-18684645,-11443503 }, + { 476239,6601091,-6152790,-9723375,17503545,-4863900,27672959,13403813,11052904,5219329 }, + }, +}, +{ + { + { 20678546,-8375738,-32671898,8849123,-5009758,14574752,31186971,-3973730,9014762,-8579056 }, + { -13644050,-10350239,-15962508,5075808,-1514661,-11534600,-33102500,9160280,8473550,-3256838 }, + { 24900749,14435722,17209120,-15292541,-22592275,9878983,-7689309,-16335821,-24568481,11788948 }, + }, + { + { -3118155,-11395194,-13802089,14797441,9652448,-6845904,-20037437,10410733,-24568470,-1458691 }, + { -15659161,16736706,-22467150,10215878,-9097177,7563911,11871841,-12505194,-18513325,8464118 }, + { -23400612,8348507,-14585951,-861714,-3950205,-6373419,14325289,8628612,33313881,-8370517 }, + }, + { + { -20186973,-4967935,22367356,5271547,-1097117,-4788838,-24805667,-10236854,-8940735,-5818269 }, + { -6948785,-1795212,-32625683,-16021179,32635414,-7374245,15989197,-12838188,28358192,-4253904 }, + { -23561781,-2799059,-32351682,-1661963,-9147719,10429267,-16637684,4072016,-5351664,5596589 }, + }, + { + { -28236598,-3390048,12312896,6213178,3117142,16078565,29266239,2557221,1768301,15373193 }, + { -7243358,-3246960,-4593467,-7553353,-127927,-912245,-1090902,-4504991,-24660491,3442910 }, + { -30210571,5124043,14181784,8197961,18964734,-11939093,22597931,7176455,-18585478,13365930 }, + }, + { + { -7877390,-1499958,8324673,4690079,6261860,890446,24538107,-8570186,-9689599,-3031667 }, + { 25008904,-10771599,-4305031,-9638010,16265036,15721635,683793,-11823784,15723479,-15163481 }, + { -9660625,12374379,-27006999,-7026148,-7724114,-12314514,11879682,5400171,519526,-1235876 }, + }, + { + { 22258397,-16332233,-7869817,14613016,-22520255,-2950923,-20353881,7315967,16648397,7605640 }, + { -8081308,-8464597,-8223311,9719710,19259459,-15348212,23994942,-5281555,-9468848,4763278 }, + { -21699244,9220969,-15730624,1084137,-25476107,-2852390,31088447,-7764523,-11356529,728112 }, + }, + { + { 26047220,-11751471,-6900323,-16521798,24092068,9158119,-4273545,-12555558,-29365436,-5498272 }, + { 17510331,-322857,5854289,8403524,17133918,-3112612,-28111007,12327945,10750447,10014012 }, + { -10312768,3936952,9156313,-8897683,16498692,-994647,-27481051,-666732,3424691,7540221 }, + }, + { + { 30322361,-6964110,11361005,-4143317,7433304,4989748,-7071422,-16317219,-9244265,15258046 }, + { 13054562,-2779497,19155474,469045,-12482797,4566042,5631406,2711395,1062915,-5136345 }, + { -19240248,-11254599,-29509029,-7499965,-5835763,13005411,-6066489,12194497,32960380,1459310 }, + }, +}, +{ + { + { 19852034,7027924,23669353,10020366,8586503,-6657907,394197,-6101885,18638003,-11174937 }, + { 31395534,15098109,26581030,8030562,-16527914,-5007134,9012486,-7584354,-6643087,-5442636 }, + { -9192165,-2347377,-1997099,4529534,25766844,607986,-13222,9677543,-32294889,-6456008 }, + }, + { + { -2444496,-149937,29348902,8186665,1873760,12489863,-30934579,-7839692,-7852844,-8138429 }, + { -15236356,-15433509,7766470,746860,26346930,-10221762,-27333451,10754588,-9431476,5203576 }, + { 31834314,14135496,-770007,5159118,20917671,-16768096,-7467973,-7337524,31809243,7347066 }, + }, + { + { -9606723,-11874240,20414459,13033986,13716524,-11691881,19797970,-12211255,15192876,-2087490 }, + { -12663563,-2181719,1168162,-3804809,26747877,-14138091,10609330,12694420,33473243,-13382104 }, + { 33184999,11180355,15832085,-11385430,-1633671,225884,15089336,-11023903,-6135662,14480053 }, + }, + { + { 31308717,-5619998,31030840,-1897099,15674547,-6582883,5496208,13685227,27595050,8737275 }, + { -20318852,-15150239,10933843,-16178022,8335352,-7546022,-31008351,-12610604,26498114,66511 }, + { 22644454,-8761729,-16671776,4884562,-3105614,-13559366,30540766,-4286747,-13327787,-7515095 }, + }, + { + { -28017847,9834845,18617207,-2681312,-3401956,-13307506,8205540,13585437,-17127465,15115439 }, + { 23711543,-672915,31206561,-8362711,6164647,-9709987,-33535882,-1426096,8236921,16492939 }, + { -23910559,-13515526,-26299483,-4503841,25005590,-7687270,19574902,10071562,6708380,-6222424 }, + }, + { + { 2101391,-4930054,19702731,2367575,-15427167,1047675,5301017,9328700,29955601,-11678310 }, + { 3096359,9271816,-21620864,-15521844,-14847996,-7592937,-25892142,-12635595,-9917575,6216608 }, + { -32615849,338663,-25195611,2510422,-29213566,-13820213,24822830,-6146567,-26767480,7525079 }, + }, + { + { -23066649,-13985623,16133487,-7896178,-3389565,778788,-910336,-2782495,-19386633,11994101 }, + { 21691500,-13624626,-641331,-14367021,3285881,-3483596,-25064666,9718258,-7477437,13381418 }, + { 18445390,-4202236,14979846,11622458,-1727110,-3582980,23111648,-6375247,28535282,15779576 }, + }, + { + { 30098053,3089662,-9234387,16662135,-21306940,11308411,-14068454,12021730,9955285,-16303356 }, + { 9734894,-14576830,-7473633,-9138735,2060392,11313496,-18426029,9924399,20194861,13380996 }, + { -26378102,-7965207,-22167821,15789297,-18055342,-6168792,-1984914,15707771,26342023,10146099 }, + }, +}, +{ + { + { -26016874,-219943,21339191,-41388,19745256,-2878700,-29637280,2227040,21612326,-545728 }, + { -13077387,1184228,23562814,-5970442,-20351244,-6348714,25764461,12243797,-20856566,11649658 }, + { -10031494,11262626,27384172,2271902,26947504,-15997771,39944,6114064,33514190,2333242 }, + }, + { + { -21433588,-12421821,8119782,7219913,-21830522,-9016134,-6679750,-12670638,24350578,-13450001 }, + { -4116307,-11271533,-23886186,4843615,-30088339,690623,-31536088,-10406836,8317860,12352766 }, + { 18200138,-14475911,-33087759,-2696619,-23702521,-9102511,-23552096,-2287550,20712163,6719373 }, + }, + { + { 26656208,6075253,-7858556,1886072,-28344043,4262326,11117530,-3763210,26224235,-3297458 }, + { -17168938,-14854097,-3395676,-16369877,-19954045,14050420,21728352,9493610,18620611,-16428628 }, + { -13323321,13325349,11432106,5964811,18609221,6062965,-5269471,-9725556,-30701573,-16479657 }, + }, + { + { -23860538,-11233159,26961357,1640861,-32413112,-16737940,12248509,-5240639,13735342,1934062 }, + { 25089769,6742589,17081145,-13406266,21909293,-16067981,-15136294,-3765346,-21277997,5473616 }, + { 31883677,-7961101,1083432,-11572403,22828471,13290673,-7125085,12469656,29111212,-5451014 }, + }, + { + { 24244947,-15050407,-26262976,2791540,-14997599,16666678,24367466,6388839,-10295587,452383 }, + { -25640782,-3417841,5217916,16224624,19987036,-4082269,-24236251,-5915248,15766062,8407814 }, + { -20406999,13990231,15495425,16395525,5377168,15166495,-8917023,-4388953,-8067909,2276718 }, + }, + { + { 30157918,12924066,-17712050,9245753,19895028,3368142,-23827587,5096219,22740376,-7303417 }, + { 2041139,-14256350,7783687,13876377,-25946985,-13352459,24051124,13742383,-15637599,13295222 }, + { 33338237,-8505733,12532113,7977527,9106186,-1715251,-17720195,-4612972,-4451357,-14669444 }, + }, + { + { -20045281,5454097,-14346548,6447146,28862071,1883651,-2469266,-4141880,7770569,9620597 }, + { 23208068,7979712,33071466,8149229,1758231,-10834995,30945528,-1694323,-33502340,-14767970 }, + { 1439958,-16270480,-1079989,-793782,4625402,10647766,-5043801,1220118,30494170,-11440799 }, + }, + { + { -5037580,-13028295,-2970559,-3061767,15640974,-6701666,-26739026,926050,-1684339,-13333647 }, + { 13908495,-3549272,30919928,-6273825,-21521863,7989039,9021034,9078865,3353509,4033511 }, + { -29663431,-15113610,32259991,-344482,24295849,-12912123,23161163,8839127,27485041,7356032 }, + }, +}, +{ + { + { 9661027,705443,11980065,-5370154,-1628543,14661173,-6346142,2625015,28431036,-16771834 }, + { -23839233,-8311415,-25945511,7480958,-17681669,-8354183,-22545972,14150565,15970762,4099461 }, + { 29262576,16756590,26350592,-8793563,8529671,-11208050,13617293,-9937143,11465739,8317062 }, + }, + { + { -25493081,-6962928,32500200,-9419051,-23038724,-2302222,14898637,3848455,20969334,-5157516 }, + { -20384450,-14347713,-18336405,13884722,-33039454,2842114,-21610826,-3649888,11177095,14989547 }, + { -24496721,-11716016,16959896,2278463,12066309,10137771,13515641,2581286,-28487508,9930240 }, + }, + { + { -17751622,-2097826,16544300,-13009300,-15914807,-14949081,18345767,-13403753,16291481,-5314038 }, + { -33229194,2553288,32678213,9875984,8534129,6889387,-9676774,6957617,4368891,9788741 }, + { 16660756,7281060,-10830758,12911820,20108584,-8101676,-21722536,-8613148,16250552,-11111103 }, + }, + { + { -19765507,2390526,-16551031,14161980,1905286,6414907,4689584,10604807,-30190403,4782747 }, + { -1354539,14736941,-7367442,-13292886,7710542,-14155590,-9981571,4383045,22546403,437323 }, + { 31665577,-12180464,-16186830,1491339,-18368625,3294682,27343084,2786261,-30633590,-14097016 }, + }, + { + { -14467279,-683715,-33374107,7448552,19294360,14334329,-19690631,2355319,-19284671,-6114373 }, + { 15121312,-15796162,6377020,-6031361,-10798111,-12957845,18952177,15496498,-29380133,11754228 }, + { -2637277,-13483075,8488727,-14303896,12728761,-1622493,7141596,11724556,22761615,-10134141 }, + }, + { + { 16918416,11729663,-18083579,3022987,-31015732,-13339659,-28741185,-12227393,32851222,11717399 }, + { 11166634,7338049,-6722523,4531520,-29468672,-7302055,31474879,3483633,-1193175,-4030831 }, + { -185635,9921305,31456609,-13536438,-12013818,13348923,33142652,6546660,-19985279,-3948376 }, + }, + { + { -32460596,11266712,-11197107,-7899103,31703694,3855903,-8537131,-12833048,-30772034,-15486313 }, + { -18006477,12709068,3991746,-6479188,-21491523,-10550425,-31135347,-16049879,10928917,3011958 }, + { -6957757,-15594337,31696059,334240,29576716,14796075,-30831056,-12805180,18008031,10258577 }, + }, + { + { -22448644,15655569,7018479,-4410003,-30314266,-1201591,-1853465,1367120,25127874,6671743 }, + { 29701166,-14373934,-10878120,9279288,-17568,13127210,21382910,11042292,25838796,4642684 }, + { -20430234,14955537,-24126347,8124619,-5369288,-5990470,30468147,-13900640,18423289,4177476 }, + }, +}, diff --git a/bundled/cbits/ref10/include/base2.h b/bundled/cbits/ref10/include/base2.h new file mode 100644 index 0000000..8c53844 --- /dev/null +++ b/bundled/cbits/ref10/include/base2.h @@ -0,0 +1,40 @@ + { + { 25967493,-14356035,29566456,3660896,-12694345,4014787,27544626,-11754271,-6079156,2047605 }, + { -12545711,934262,-2722910,3049990,-727428,9406986,12720692,5043384,19500929,-15469378 }, + { -8738181,4489570,9688441,-14785194,10184609,-12363380,29287919,11864899,-24514362,-4438546 }, + }, + { + { 15636291,-9688557,24204773,-7912398,616977,-16685262,27787600,-14772189,28944400,-1550024 }, + { 16568933,4717097,-11556148,-1102322,15682896,-11807043,16354577,-11775962,7689662,11199574 }, + { 30464156,-5976125,-11779434,-15670865,23220365,15915852,7512774,10017326,-17749093,-9920357 }, + }, + { + { 10861363,11473154,27284546,1981175,-30064349,12577861,32867885,14515107,-15438304,10819380 }, + { 4708026,6336745,20377586,9066809,-11272109,6594696,-25653668,12483688,-12668491,5581306 }, + { 19563160,16186464,-29386857,4097519,10237984,-4348115,28542350,13850243,-23678021,-15815942 }, + }, + { + { 5153746,9909285,1723747,-2777874,30523605,5516873,19480852,5230134,-23952439,-15175766 }, + { -30269007,-3463509,7665486,10083793,28475525,1649722,20654025,16520125,30598449,7715701 }, + { 28881845,14381568,9657904,3680757,-20181635,7843316,-31400660,1370708,29794553,-1409300 }, + }, + { + { -22518993,-6692182,14201702,-8745502,-23510406,8844726,18474211,-1361450,-13062696,13821877 }, + { -6455177,-7839871,3374702,-4740862,-27098617,-10571707,31655028,-7212327,18853322,-14220951 }, + { 4566830,-12963868,-28974889,-12240689,-7602672,-2830569,-8514358,-10431137,2207753,-3209784 }, + }, + { + { -25154831,-4185821,29681144,7868801,-6854661,-9423865,-12437364,-663000,-31111463,-16132436 }, + { 25576264,-2703214,7349804,-11814844,16472782,9300885,3844789,15725684,171356,6466918 }, + { 23103977,13316479,9739013,-16149481,817875,-15038942,8965339,-14088058,-30714912,16193877 }, + }, + { + { -33521811,3180713,-2394130,14003687,-16903474,-16270840,17238398,4729455,-18074513,9256800 }, + { -25182317,-4174131,32336398,5036987,-21236817,11360617,22616405,9761698,-19827198,630305 }, + { -13720693,2639453,-24237460,-7406481,9494427,-5774029,-6554551,-15960994,-2449256,-14291300 }, + }, + { + { -3151181,-5046075,9282714,6866145,-31907062,-863023,-18940575,15033784,25105118,-7894876 }, + { -24326370,15950226,-31801215,-14592823,-11662737,-5090925,1573892,-2625887,2198790,-15804619 }, + { -3099351,10324967,-2241613,7453183,-5446979,-2735503,-13812022,-16236442,-32461234,-12290683 }, + }, diff --git a/bundled/cbits/ref10/include/crypto_int16.h b/bundled/cbits/ref10/include/crypto_int16.h new file mode 100644 index 0000000..9d9cffe --- /dev/null +++ b/bundled/cbits/ref10/include/crypto_int16.h @@ -0,0 +1,7 @@ +#ifndef crypto_int16_h +#define crypto_int16_h + +#include +typedef int16_t crypto_int16; + +#endif diff --git a/bundled/cbits/ref10/include/crypto_int32.h b/bundled/cbits/ref10/include/crypto_int32.h new file mode 100644 index 0000000..79f0733 --- /dev/null +++ b/bundled/cbits/ref10/include/crypto_int32.h @@ -0,0 +1,7 @@ +#ifndef crypto_int32_h +#define crypto_int32_h + +#include +typedef int32_t crypto_int32; + +#endif diff --git a/bundled/cbits/ref10/include/crypto_int64.h b/bundled/cbits/ref10/include/crypto_int64.h new file mode 100644 index 0000000..06fb901 --- /dev/null +++ b/bundled/cbits/ref10/include/crypto_int64.h @@ -0,0 +1,7 @@ +#ifndef crypto_int64_h +#define crypto_int64_h + +#include +typedef int64_t crypto_int64; + +#endif diff --git a/bundled/cbits/ref10/include/crypto_int8.h b/bundled/cbits/ref10/include/crypto_int8.h new file mode 100644 index 0000000..fc1dd68 --- /dev/null +++ b/bundled/cbits/ref10/include/crypto_int8.h @@ -0,0 +1,7 @@ +#ifndef crypto_int8_h +#define crypto_int8_h + +#include +typedef int8_t crypto_int8; + +#endif diff --git a/bundled/cbits/ref10/include/crypto_uint16.h b/bundled/cbits/ref10/include/crypto_uint16.h new file mode 100644 index 0000000..850a0e5 --- /dev/null +++ b/bundled/cbits/ref10/include/crypto_uint16.h @@ -0,0 +1,7 @@ +#ifndef crypto_uint16_h +#define crypto_uint16_h + +#include +typedef uint16_t crypto_uint16; + +#endif diff --git a/bundled/cbits/ref10/include/crypto_uint32.h b/bundled/cbits/ref10/include/crypto_uint32.h new file mode 100644 index 0000000..221cde2 --- /dev/null +++ b/bundled/cbits/ref10/include/crypto_uint32.h @@ -0,0 +1,7 @@ +#ifndef crypto_uint32_h +#define crypto_uint32_h + +#include +typedef uint32_t crypto_uint32; + +#endif diff --git a/bundled/cbits/ref10/include/crypto_uint64.h b/bundled/cbits/ref10/include/crypto_uint64.h new file mode 100644 index 0000000..b0d35cb --- /dev/null +++ b/bundled/cbits/ref10/include/crypto_uint64.h @@ -0,0 +1,7 @@ +#ifndef crypto_uint64_h +#define crypto_uint64_h + +#include +typedef uint64_t crypto_uint64; + +#endif diff --git a/bundled/cbits/ref10/include/crypto_uint8.h b/bundled/cbits/ref10/include/crypto_uint8.h new file mode 100644 index 0000000..a7ab231 --- /dev/null +++ b/bundled/cbits/ref10/include/crypto_uint8.h @@ -0,0 +1,7 @@ +#ifndef crypto_uint8_h +#define crypto_uint8_h + +#include +typedef uint8_t crypto_uint8; + +#endif diff --git a/bundled/cbits/ref10/include/crypto_verify.h b/bundled/cbits/ref10/include/crypto_verify.h new file mode 100644 index 0000000..dfa2c90 --- /dev/null +++ b/bundled/cbits/ref10/include/crypto_verify.h @@ -0,0 +1,7 @@ +#ifndef crypto_verify_16_H +#define crypto_verify_16_H + +static inline int crypto_verify_16(const unsigned char *,const unsigned char *); +static inline int crypto_verify_32(const unsigned char *,const unsigned char *); + +#endif diff --git a/bundled/cbits/ref10/include/d.h b/bundled/cbits/ref10/include/d.h new file mode 100644 index 0000000..e25f578 --- /dev/null +++ b/bundled/cbits/ref10/include/d.h @@ -0,0 +1 @@ +-10913610,13857413,-15372611,6949391,114729,-8787816,-6275908,-3247719,-18696448,-12055116 diff --git a/bundled/cbits/ref10/include/d2.h b/bundled/cbits/ref10/include/d2.h new file mode 100644 index 0000000..01aaec7 --- /dev/null +++ b/bundled/cbits/ref10/include/d2.h @@ -0,0 +1 @@ +-21827239,-5839606,-30745221,13898782,229458,15978800,-12551817,-6495438,29715968,9444199 diff --git a/bundled/cbits/ref10/include/ed25519.h b/bundled/cbits/ref10/include/ed25519.h new file mode 100644 index 0000000..0391eac --- /dev/null +++ b/bundled/cbits/ref10/include/ed25519.h @@ -0,0 +1,21 @@ +#ifndef _ED25519_H_ +#define _ED25519_H_ + +#define crypto_sign_SECRETKEYBYTES 64 +#define crypto_sign_PUBLICKEYBYTES 32 +#define crypto_sign_BYTES 64 +#define crypto_sign_PRIMITIVE "ed25519" +#define crypto_sign_IMPLEMENTATION crypto_sign_ed25519_IMPLEMENTATION +#define crypto_sign_VERSION crypto_sign_ed25519_VERSION + +int ed25519_sign_seed_keypair(unsigned char *pk, unsigned char *sk, + const unsigned char *seed); +int ed25519_sign_keypair(unsigned char *pk,unsigned char *sk); +int ed25519_sign(unsigned char *sm,unsigned long long *smlen, + const unsigned char *m,unsigned long long mlen, + const unsigned char *sk); +int ed25519_sign_open(unsigned char *m,unsigned long long *mlen, + const unsigned char *sm,unsigned long long smlen, + const unsigned char *pk); + +#endif /* _ED25519_H_ */ diff --git a/bundled/cbits/ref10/include/fe.h b/bundled/cbits/ref10/include/fe.h new file mode 100644 index 0000000..53cd4ba --- /dev/null +++ b/bundled/cbits/ref10/include/fe.h @@ -0,0 +1,52 @@ +#ifndef FE_H +#define FE_H + +#include "crypto_int32.h" + +typedef crypto_int32 fe[10]; + +/* +fe means field element. +Here the field is \Z/(2^255-19). +An element t, entries t[0]...t[9], represents the integer +t[0]+2^26 t[1]+2^51 t[2]+2^77 t[3]+2^102 t[4]+...+2^230 t[9]. +Bounds on each t[i] vary depending on context. +*/ + +#define fe_frombytes crypto_sign_ed25519_ref10_fe_frombytes +#define fe_tobytes crypto_sign_ed25519_ref10_fe_tobytes +#define fe_copy crypto_sign_ed25519_ref10_fe_copy +#define fe_isnonzero crypto_sign_ed25519_ref10_fe_isnonzero +#define fe_isnegative crypto_sign_ed25519_ref10_fe_isnegative +#define fe_0 crypto_sign_ed25519_ref10_fe_0 +#define fe_1 crypto_sign_ed25519_ref10_fe_1 +#define fe_cmov crypto_sign_ed25519_ref10_fe_cmov +#define fe_add crypto_sign_ed25519_ref10_fe_add +#define fe_sub crypto_sign_ed25519_ref10_fe_sub +#define fe_neg crypto_sign_ed25519_ref10_fe_neg +#define fe_mul crypto_sign_ed25519_ref10_fe_mul +#define fe_sq crypto_sign_ed25519_ref10_fe_sq +#define fe_sq2 crypto_sign_ed25519_ref10_fe_sq2 +#define fe_invert crypto_sign_ed25519_ref10_fe_invert +#define fe_pow22523 crypto_sign_ed25519_ref10_fe_pow22523 + +static inline void fe_frombytes(fe,const unsigned char *); +static inline void fe_tobytes(unsigned char *,const fe); + +static inline void fe_copy(fe,const fe); +static inline int fe_isnonzero(const fe); +static inline int fe_isnegative(const fe); +static inline void fe_0(fe); +static inline void fe_1(fe); +static inline void fe_cmov(fe,const fe,unsigned int); + +static inline void fe_add(fe,const fe,const fe); +static inline void fe_sub(fe,const fe,const fe); +static inline void fe_neg(fe,const fe); +static inline void fe_mul(fe,const fe,const fe); +static inline void fe_sq(fe,const fe); +static inline void fe_sq2(fe,const fe); +static inline void fe_invert(fe,const fe); +static inline void fe_pow22523(fe,const fe); + +#endif diff --git a/bundled/cbits/ref10/include/ge.h b/bundled/cbits/ref10/include/ge.h new file mode 100644 index 0000000..3d0363e --- /dev/null +++ b/bundled/cbits/ref10/include/ge.h @@ -0,0 +1,95 @@ +#ifndef GE_H +#define GE_H + +/* +ge means group element. + +Here the group is the set of pairs (x,y) of field elements (see fe.h) +satisfying -x^2 + y^2 = 1 + d x^2y^2 +where d = -121665/121666. + +Representations: + ge_p2 (projective): (X:Y:Z) satisfying x=X/Z, y=Y/Z + ge_p3 (extended): (X:Y:Z:T) satisfying x=X/Z, y=Y/Z, XY=ZT + ge_p1p1 (completed): ((X:Z),(Y:T)) satisfying x=X/Z, y=Y/T + ge_precomp (Duif): (y+x,y-x,2dxy) +*/ + +#include "fe.h" + +typedef struct { + fe X; + fe Y; + fe Z; +} ge_p2; + +typedef struct { + fe X; + fe Y; + fe Z; + fe T; +} ge_p3; + +typedef struct { + fe X; + fe Y; + fe Z; + fe T; +} ge_p1p1; + +typedef struct { + fe yplusx; + fe yminusx; + fe xy2d; +} ge_precomp; + +typedef struct { + fe YplusX; + fe YminusX; + fe Z; + fe T2d; +} ge_cached; + +#define ge_frombytes_negate_vartime crypto_sign_ed25519_ref10_ge_frombytes_negate_vartime +#define ge_tobytes crypto_sign_ed25519_ref10_ge_tobytes +#define ge_p3_tobytes crypto_sign_ed25519_ref10_ge_p3_tobytes + +#define ge_p2_0 crypto_sign_ed25519_ref10_ge_p2_0 +#define ge_p3_0 crypto_sign_ed25519_ref10_ge_p3_0 +#define ge_precomp_0 crypto_sign_ed25519_ref10_ge_precomp_0 +#define ge_p3_to_p2 crypto_sign_ed25519_ref10_ge_p3_to_p2 +#define ge_p3_to_cached crypto_sign_ed25519_ref10_ge_p3_to_cached +#define ge_p1p1_to_p2 crypto_sign_ed25519_ref10_ge_p1p1_to_p2 +#define ge_p1p1_to_p3 crypto_sign_ed25519_ref10_ge_p1p1_to_p3 +#define ge_p2_dbl crypto_sign_ed25519_ref10_ge_p2_dbl +#define ge_p3_dbl crypto_sign_ed25519_ref10_ge_p3_dbl + +#define ge_madd crypto_sign_ed25519_ref10_ge_madd +#define ge_msub crypto_sign_ed25519_ref10_ge_msub +#define ge_add crypto_sign_ed25519_ref10_ge_add +#define ge_sub crypto_sign_ed25519_ref10_ge_sub +#define ge_scalarmult_base crypto_sign_ed25519_ref10_ge_scalarmult_base +#define ge_double_scalarmult_vartime crypto_sign_ed25519_ref10_ge_double_scalarmult_vartime + +static inline void ge_tobytes(unsigned char *,const ge_p2 *); +static inline void ge_p3_tobytes(unsigned char *,const ge_p3 *); +static inline int ge_frombytes_negate_vartime(ge_p3 *,const unsigned char *); + +static inline void ge_p2_0(ge_p2 *); +static inline void ge_p3_0(ge_p3 *); +static inline void ge_precomp_0(ge_precomp *); +static inline void ge_p3_to_p2(ge_p2 *,const ge_p3 *); +static inline void ge_p3_to_cached(ge_cached *,const ge_p3 *); +static inline void ge_p1p1_to_p2(ge_p2 *,const ge_p1p1 *); +static inline void ge_p1p1_to_p3(ge_p3 *,const ge_p1p1 *); +static inline void ge_p2_dbl(ge_p1p1 *,const ge_p2 *); +static inline void ge_p3_dbl(ge_p1p1 *,const ge_p3 *); + +static inline void ge_madd(ge_p1p1 *,const ge_p3 *,const ge_precomp *); +static inline void ge_msub(ge_p1p1 *,const ge_p3 *,const ge_precomp *); +static inline void ge_add(ge_p1p1 *,const ge_p3 *,const ge_cached *); +static inline void ge_sub(ge_p1p1 *,const ge_p3 *,const ge_cached *); +static inline void ge_scalarmult_base(ge_p3 *,const unsigned char *); +static inline void ge_double_scalarmult_vartime(ge_p2 *,const unsigned char *,const ge_p3 *,const unsigned char *); + +#endif diff --git a/bundled/cbits/ref10/include/ge_add.h b/bundled/cbits/ref10/include/ge_add.h new file mode 100644 index 0000000..7481f8f --- /dev/null +++ b/bundled/cbits/ref10/include/ge_add.h @@ -0,0 +1,97 @@ + +/* qhasm: enter ge_add */ + +/* qhasm: fe X1 */ + +/* qhasm: fe Y1 */ + +/* qhasm: fe Z1 */ + +/* qhasm: fe Z2 */ + +/* qhasm: fe T1 */ + +/* qhasm: fe ZZ */ + +/* qhasm: fe YpX2 */ + +/* qhasm: fe YmX2 */ + +/* qhasm: fe T2d2 */ + +/* qhasm: fe X3 */ + +/* qhasm: fe Y3 */ + +/* qhasm: fe Z3 */ + +/* qhasm: fe T3 */ + +/* qhasm: fe YpX1 */ + +/* qhasm: fe YmX1 */ + +/* qhasm: fe A */ + +/* qhasm: fe B */ + +/* qhasm: fe C */ + +/* qhasm: fe D */ + +/* qhasm: YpX1 = Y1+X1 */ +/* asm 1: fe_add(>YpX1=fe#1,YpX1=r->X,Y,X); */ +fe_add(r->X,p->Y,p->X); + +/* qhasm: YmX1 = Y1-X1 */ +/* asm 1: fe_sub(>YmX1=fe#2,YmX1=r->Y,Y,X); */ +fe_sub(r->Y,p->Y,p->X); + +/* qhasm: A = YpX1*YpX2 */ +/* asm 1: fe_mul(>A=fe#3,A=r->Z,X,YplusX); */ +fe_mul(r->Z,r->X,q->YplusX); + +/* qhasm: B = YmX1*YmX2 */ +/* asm 1: fe_mul(>B=fe#2,B=r->Y,Y,YminusX); */ +fe_mul(r->Y,r->Y,q->YminusX); + +/* qhasm: C = T2d2*T1 */ +/* asm 1: fe_mul(>C=fe#4,C=r->T,T2d,T); */ +fe_mul(r->T,q->T2d,p->T); + +/* qhasm: ZZ = Z1*Z2 */ +/* asm 1: fe_mul(>ZZ=fe#1,ZZ=r->X,Z,Z); */ +fe_mul(r->X,p->Z,q->Z); + +/* qhasm: D = 2*ZZ */ +/* asm 1: fe_add(>D=fe#5,D=t0,X,X); */ +fe_add(t0,r->X,r->X); + +/* qhasm: X3 = A-B */ +/* asm 1: fe_sub(>X3=fe#1,X3=r->X,Z,Y); */ +fe_sub(r->X,r->Z,r->Y); + +/* qhasm: Y3 = A+B */ +/* asm 1: fe_add(>Y3=fe#2,Y3=r->Y,Z,Y); */ +fe_add(r->Y,r->Z,r->Y); + +/* qhasm: Z3 = D+C */ +/* asm 1: fe_add(>Z3=fe#3,Z3=r->Z,T); */ +fe_add(r->Z,t0,r->T); + +/* qhasm: T3 = D-C */ +/* asm 1: fe_sub(>T3=fe#4,T3=r->T,T); */ +fe_sub(r->T,t0,r->T); + +/* qhasm: return */ diff --git a/bundled/cbits/ref10/include/ge_madd.h b/bundled/cbits/ref10/include/ge_madd.h new file mode 100644 index 0000000..ecae849 --- /dev/null +++ b/bundled/cbits/ref10/include/ge_madd.h @@ -0,0 +1,88 @@ + +/* qhasm: enter ge_madd */ + +/* qhasm: fe X1 */ + +/* qhasm: fe Y1 */ + +/* qhasm: fe Z1 */ + +/* qhasm: fe T1 */ + +/* qhasm: fe ypx2 */ + +/* qhasm: fe ymx2 */ + +/* qhasm: fe xy2d2 */ + +/* qhasm: fe X3 */ + +/* qhasm: fe Y3 */ + +/* qhasm: fe Z3 */ + +/* qhasm: fe T3 */ + +/* qhasm: fe YpX1 */ + +/* qhasm: fe YmX1 */ + +/* qhasm: fe A */ + +/* qhasm: fe B */ + +/* qhasm: fe C */ + +/* qhasm: fe D */ + +/* qhasm: YpX1 = Y1+X1 */ +/* asm 1: fe_add(>YpX1=fe#1,YpX1=r->X,Y,X); */ +fe_add(r->X,p->Y,p->X); + +/* qhasm: YmX1 = Y1-X1 */ +/* asm 1: fe_sub(>YmX1=fe#2,YmX1=r->Y,Y,X); */ +fe_sub(r->Y,p->Y,p->X); + +/* qhasm: A = YpX1*ypx2 */ +/* asm 1: fe_mul(>A=fe#3,A=r->Z,X,yplusx); */ +fe_mul(r->Z,r->X,q->yplusx); + +/* qhasm: B = YmX1*ymx2 */ +/* asm 1: fe_mul(>B=fe#2,B=r->Y,Y,yminusx); */ +fe_mul(r->Y,r->Y,q->yminusx); + +/* qhasm: C = xy2d2*T1 */ +/* asm 1: fe_mul(>C=fe#4,C=r->T,xy2d,T); */ +fe_mul(r->T,q->xy2d,p->T); + +/* qhasm: D = 2*Z1 */ +/* asm 1: fe_add(>D=fe#5,D=t0,Z,Z); */ +fe_add(t0,p->Z,p->Z); + +/* qhasm: X3 = A-B */ +/* asm 1: fe_sub(>X3=fe#1,X3=r->X,Z,Y); */ +fe_sub(r->X,r->Z,r->Y); + +/* qhasm: Y3 = A+B */ +/* asm 1: fe_add(>Y3=fe#2,Y3=r->Y,Z,Y); */ +fe_add(r->Y,r->Z,r->Y); + +/* qhasm: Z3 = D+C */ +/* asm 1: fe_add(>Z3=fe#3,Z3=r->Z,T); */ +fe_add(r->Z,t0,r->T); + +/* qhasm: T3 = D-C */ +/* asm 1: fe_sub(>T3=fe#4,T3=r->T,T); */ +fe_sub(r->T,t0,r->T); + +/* qhasm: return */ diff --git a/bundled/cbits/ref10/include/ge_msub.h b/bundled/cbits/ref10/include/ge_msub.h new file mode 100644 index 0000000..500f986 --- /dev/null +++ b/bundled/cbits/ref10/include/ge_msub.h @@ -0,0 +1,88 @@ + +/* qhasm: enter ge_msub */ + +/* qhasm: fe X1 */ + +/* qhasm: fe Y1 */ + +/* qhasm: fe Z1 */ + +/* qhasm: fe T1 */ + +/* qhasm: fe ypx2 */ + +/* qhasm: fe ymx2 */ + +/* qhasm: fe xy2d2 */ + +/* qhasm: fe X3 */ + +/* qhasm: fe Y3 */ + +/* qhasm: fe Z3 */ + +/* qhasm: fe T3 */ + +/* qhasm: fe YpX1 */ + +/* qhasm: fe YmX1 */ + +/* qhasm: fe A */ + +/* qhasm: fe B */ + +/* qhasm: fe C */ + +/* qhasm: fe D */ + +/* qhasm: YpX1 = Y1+X1 */ +/* asm 1: fe_add(>YpX1=fe#1,YpX1=r->X,Y,X); */ +fe_add(r->X,p->Y,p->X); + +/* qhasm: YmX1 = Y1-X1 */ +/* asm 1: fe_sub(>YmX1=fe#2,YmX1=r->Y,Y,X); */ +fe_sub(r->Y,p->Y,p->X); + +/* qhasm: A = YpX1*ymx2 */ +/* asm 1: fe_mul(>A=fe#3,A=r->Z,X,yminusx); */ +fe_mul(r->Z,r->X,q->yminusx); + +/* qhasm: B = YmX1*ypx2 */ +/* asm 1: fe_mul(>B=fe#2,B=r->Y,Y,yplusx); */ +fe_mul(r->Y,r->Y,q->yplusx); + +/* qhasm: C = xy2d2*T1 */ +/* asm 1: fe_mul(>C=fe#4,C=r->T,xy2d,T); */ +fe_mul(r->T,q->xy2d,p->T); + +/* qhasm: D = 2*Z1 */ +/* asm 1: fe_add(>D=fe#5,D=t0,Z,Z); */ +fe_add(t0,p->Z,p->Z); + +/* qhasm: X3 = A-B */ +/* asm 1: fe_sub(>X3=fe#1,X3=r->X,Z,Y); */ +fe_sub(r->X,r->Z,r->Y); + +/* qhasm: Y3 = A+B */ +/* asm 1: fe_add(>Y3=fe#2,Y3=r->Y,Z,Y); */ +fe_add(r->Y,r->Z,r->Y); + +/* qhasm: Z3 = D-C */ +/* asm 1: fe_sub(>Z3=fe#3,Z3=r->Z,T); */ +fe_sub(r->Z,t0,r->T); + +/* qhasm: T3 = D+C */ +/* asm 1: fe_add(>T3=fe#4,T3=r->T,T); */ +fe_add(r->T,t0,r->T); + +/* qhasm: return */ diff --git a/bundled/cbits/ref10/include/ge_p2_dbl.h b/bundled/cbits/ref10/include/ge_p2_dbl.h new file mode 100644 index 0000000..128efed --- /dev/null +++ b/bundled/cbits/ref10/include/ge_p2_dbl.h @@ -0,0 +1,73 @@ + +/* qhasm: enter ge_p2_dbl */ + +/* qhasm: fe X1 */ + +/* qhasm: fe Y1 */ + +/* qhasm: fe Z1 */ + +/* qhasm: fe A */ + +/* qhasm: fe AA */ + +/* qhasm: fe XX */ + +/* qhasm: fe YY */ + +/* qhasm: fe B */ + +/* qhasm: fe X3 */ + +/* qhasm: fe Y3 */ + +/* qhasm: fe Z3 */ + +/* qhasm: fe T3 */ + +/* qhasm: XX=X1^2 */ +/* asm 1: fe_sq(>XX=fe#1,XX=r->X,X); */ +fe_sq(r->X,p->X); + +/* qhasm: YY=Y1^2 */ +/* asm 1: fe_sq(>YY=fe#3,YY=r->Z,Y); */ +fe_sq(r->Z,p->Y); + +/* qhasm: B=2*Z1^2 */ +/* asm 1: fe_sq2(>B=fe#4,B=r->T,Z); */ +fe_sq2(r->T,p->Z); + +/* qhasm: A=X1+Y1 */ +/* asm 1: fe_add(>A=fe#2,A=r->Y,X,Y); */ +fe_add(r->Y,p->X,p->Y); + +/* qhasm: AA=A^2 */ +/* asm 1: fe_sq(>AA=fe#5,AA=t0,Y); */ +fe_sq(t0,r->Y); + +/* qhasm: Y3=YY+XX */ +/* asm 1: fe_add(>Y3=fe#2,Y3=r->Y,Z,X); */ +fe_add(r->Y,r->Z,r->X); + +/* qhasm: Z3=YY-XX */ +/* asm 1: fe_sub(>Z3=fe#3,Z3=r->Z,Z,X); */ +fe_sub(r->Z,r->Z,r->X); + +/* qhasm: X3=AA-Y3 */ +/* asm 1: fe_sub(>X3=fe#1,X3=r->X,Y); */ +fe_sub(r->X,t0,r->Y); + +/* qhasm: T3=B-Z3 */ +/* asm 1: fe_sub(>T3=fe#4,T3=r->T,T,Z); */ +fe_sub(r->T,r->T,r->Z); + +/* qhasm: return */ diff --git a/bundled/cbits/ref10/include/ge_sub.h b/bundled/cbits/ref10/include/ge_sub.h new file mode 100644 index 0000000..b4ef1f5 --- /dev/null +++ b/bundled/cbits/ref10/include/ge_sub.h @@ -0,0 +1,97 @@ + +/* qhasm: enter ge_sub */ + +/* qhasm: fe X1 */ + +/* qhasm: fe Y1 */ + +/* qhasm: fe Z1 */ + +/* qhasm: fe Z2 */ + +/* qhasm: fe T1 */ + +/* qhasm: fe ZZ */ + +/* qhasm: fe YpX2 */ + +/* qhasm: fe YmX2 */ + +/* qhasm: fe T2d2 */ + +/* qhasm: fe X3 */ + +/* qhasm: fe Y3 */ + +/* qhasm: fe Z3 */ + +/* qhasm: fe T3 */ + +/* qhasm: fe YpX1 */ + +/* qhasm: fe YmX1 */ + +/* qhasm: fe A */ + +/* qhasm: fe B */ + +/* qhasm: fe C */ + +/* qhasm: fe D */ + +/* qhasm: YpX1 = Y1+X1 */ +/* asm 1: fe_add(>YpX1=fe#1,YpX1=r->X,Y,X); */ +fe_add(r->X,p->Y,p->X); + +/* qhasm: YmX1 = Y1-X1 */ +/* asm 1: fe_sub(>YmX1=fe#2,YmX1=r->Y,Y,X); */ +fe_sub(r->Y,p->Y,p->X); + +/* qhasm: A = YpX1*YmX2 */ +/* asm 1: fe_mul(>A=fe#3,A=r->Z,X,YminusX); */ +fe_mul(r->Z,r->X,q->YminusX); + +/* qhasm: B = YmX1*YpX2 */ +/* asm 1: fe_mul(>B=fe#2,B=r->Y,Y,YplusX); */ +fe_mul(r->Y,r->Y,q->YplusX); + +/* qhasm: C = T2d2*T1 */ +/* asm 1: fe_mul(>C=fe#4,C=r->T,T2d,T); */ +fe_mul(r->T,q->T2d,p->T); + +/* qhasm: ZZ = Z1*Z2 */ +/* asm 1: fe_mul(>ZZ=fe#1,ZZ=r->X,Z,Z); */ +fe_mul(r->X,p->Z,q->Z); + +/* qhasm: D = 2*ZZ */ +/* asm 1: fe_add(>D=fe#5,D=t0,X,X); */ +fe_add(t0,r->X,r->X); + +/* qhasm: X3 = A-B */ +/* asm 1: fe_sub(>X3=fe#1,X3=r->X,Z,Y); */ +fe_sub(r->X,r->Z,r->Y); + +/* qhasm: Y3 = A+B */ +/* asm 1: fe_add(>Y3=fe#2,Y3=r->Y,Z,Y); */ +fe_add(r->Y,r->Z,r->Y); + +/* qhasm: Z3 = D-C */ +/* asm 1: fe_sub(>Z3=fe#3,Z3=r->Z,T); */ +fe_sub(r->Z,t0,r->T); + +/* qhasm: T3 = D+C */ +/* asm 1: fe_add(>T3=fe#4,T3=r->T,T); */ +fe_add(r->T,t0,r->T); + +/* qhasm: return */ diff --git a/bundled/cbits/ref10/include/load.h b/bundled/cbits/ref10/include/load.h new file mode 100644 index 0000000..6c88a15 --- /dev/null +++ b/bundled/cbits/ref10/include/load.h @@ -0,0 +1,23 @@ +#ifndef CRYPTO_LOAD_H +#define CRYPTO_LOAD_H + +static inline crypto_uint64 load_3(const unsigned char *in) +{ + crypto_uint64 result; + result = (crypto_uint64) in[0]; + result |= ((crypto_uint64) in[1]) << 8; + result |= ((crypto_uint64) in[2]) << 16; + return result; +} + +static inline crypto_uint64 load_4(const unsigned char *in) +{ + crypto_uint64 result; + result = (crypto_uint64) in[0]; + result |= ((crypto_uint64) in[1]) << 8; + result |= ((crypto_uint64) in[2]) << 16; + result |= ((crypto_uint64) in[3]) << 24; + return result; +} + +#endif /* CRYPTO_LOAD_H */ diff --git a/bundled/cbits/ref10/include/pow22523.h b/bundled/cbits/ref10/include/pow22523.h new file mode 100644 index 0000000..60ffe0d --- /dev/null +++ b/bundled/cbits/ref10/include/pow22523.h @@ -0,0 +1,160 @@ + +/* qhasm: fe z1 */ + +/* qhasm: fe z2 */ + +/* qhasm: fe z8 */ + +/* qhasm: fe z9 */ + +/* qhasm: fe z11 */ + +/* qhasm: fe z22 */ + +/* qhasm: fe z_5_0 */ + +/* qhasm: fe z_10_5 */ + +/* qhasm: fe z_10_0 */ + +/* qhasm: fe z_20_10 */ + +/* qhasm: fe z_20_0 */ + +/* qhasm: fe z_40_20 */ + +/* qhasm: fe z_40_0 */ + +/* qhasm: fe z_50_10 */ + +/* qhasm: fe z_50_0 */ + +/* qhasm: fe z_100_50 */ + +/* qhasm: fe z_100_0 */ + +/* qhasm: fe z_200_100 */ + +/* qhasm: fe z_200_0 */ + +/* qhasm: fe z_250_50 */ + +/* qhasm: fe z_250_0 */ + +/* qhasm: fe z_252_2 */ + +/* qhasm: fe z_252_3 */ + +/* qhasm: enter pow22523 */ + +/* qhasm: z2 = z1^2^1 */ +/* asm 1: fe_sq(>z2=fe#1,z2=fe#1,>z2=fe#1); */ +/* asm 2: fe_sq(>z2=t0,z2=t0,>z2=t0); */ +fe_sq(t0,z); for (i = 1;i < 1;++i) fe_sq(t0,t0); + +/* qhasm: z8 = z2^2^2 */ +/* asm 1: fe_sq(>z8=fe#2,z8=fe#2,>z8=fe#2); */ +/* asm 2: fe_sq(>z8=t1,z8=t1,>z8=t1); */ +fe_sq(t1,t0); for (i = 1;i < 2;++i) fe_sq(t1,t1); + +/* qhasm: z9 = z1*z8 */ +/* asm 1: fe_mul(>z9=fe#2,z9=t1,z11=fe#1,z11=t0,z22=fe#1,z22=fe#1,>z22=fe#1); */ +/* asm 2: fe_sq(>z22=t0,z22=t0,>z22=t0); */ +fe_sq(t0,t0); for (i = 1;i < 1;++i) fe_sq(t0,t0); + +/* qhasm: z_5_0 = z9*z22 */ +/* asm 1: fe_mul(>z_5_0=fe#1,z_5_0=t0,z_10_5=fe#2,z_10_5=fe#2,>z_10_5=fe#2); */ +/* asm 2: fe_sq(>z_10_5=t1,z_10_5=t1,>z_10_5=t1); */ +fe_sq(t1,t0); for (i = 1;i < 5;++i) fe_sq(t1,t1); + +/* qhasm: z_10_0 = z_10_5*z_5_0 */ +/* asm 1: fe_mul(>z_10_0=fe#1,z_10_0=t0,z_20_10=fe#2,z_20_10=fe#2,>z_20_10=fe#2); */ +/* asm 2: fe_sq(>z_20_10=t1,z_20_10=t1,>z_20_10=t1); */ +fe_sq(t1,t0); for (i = 1;i < 10;++i) fe_sq(t1,t1); + +/* qhasm: z_20_0 = z_20_10*z_10_0 */ +/* asm 1: fe_mul(>z_20_0=fe#2,z_20_0=t1,z_40_20=fe#3,z_40_20=fe#3,>z_40_20=fe#3); */ +/* asm 2: fe_sq(>z_40_20=t2,z_40_20=t2,>z_40_20=t2); */ +fe_sq(t2,t1); for (i = 1;i < 20;++i) fe_sq(t2,t2); + +/* qhasm: z_40_0 = z_40_20*z_20_0 */ +/* asm 1: fe_mul(>z_40_0=fe#2,z_40_0=t1,z_50_10=fe#2,z_50_10=fe#2,>z_50_10=fe#2); */ +/* asm 2: fe_sq(>z_50_10=t1,z_50_10=t1,>z_50_10=t1); */ +fe_sq(t1,t1); for (i = 1;i < 10;++i) fe_sq(t1,t1); + +/* qhasm: z_50_0 = z_50_10*z_10_0 */ +/* asm 1: fe_mul(>z_50_0=fe#1,z_50_0=t0,z_100_50=fe#2,z_100_50=fe#2,>z_100_50=fe#2); */ +/* asm 2: fe_sq(>z_100_50=t1,z_100_50=t1,>z_100_50=t1); */ +fe_sq(t1,t0); for (i = 1;i < 50;++i) fe_sq(t1,t1); + +/* qhasm: z_100_0 = z_100_50*z_50_0 */ +/* asm 1: fe_mul(>z_100_0=fe#2,z_100_0=t1,z_200_100=fe#3,z_200_100=fe#3,>z_200_100=fe#3); */ +/* asm 2: fe_sq(>z_200_100=t2,z_200_100=t2,>z_200_100=t2); */ +fe_sq(t2,t1); for (i = 1;i < 100;++i) fe_sq(t2,t2); + +/* qhasm: z_200_0 = z_200_100*z_100_0 */ +/* asm 1: fe_mul(>z_200_0=fe#2,z_200_0=t1,z_250_50=fe#2,z_250_50=fe#2,>z_250_50=fe#2); */ +/* asm 2: fe_sq(>z_250_50=t1,z_250_50=t1,>z_250_50=t1); */ +fe_sq(t1,t1); for (i = 1;i < 50;++i) fe_sq(t1,t1); + +/* qhasm: z_250_0 = z_250_50*z_50_0 */ +/* asm 1: fe_mul(>z_250_0=fe#1,z_250_0=t0,z_252_2=fe#1,z_252_2=fe#1,>z_252_2=fe#1); */ +/* asm 2: fe_sq(>z_252_2=t0,z_252_2=t0,>z_252_2=t0); */ +fe_sq(t0,t0); for (i = 1;i < 2;++i) fe_sq(t0,t0); + +/* qhasm: z_252_3 = z_252_2*z1 */ +/* asm 1: fe_mul(>z_252_3=fe#12,z_252_3=out,z2=fe#1,z2=fe#1,>z2=fe#1); */ +/* asm 2: fe_sq(>z2=t0,z2=t0,>z2=t0); */ +fe_sq(t0,z); for (i = 1;i < 1;++i) fe_sq(t0,t0); + +/* qhasm: z8 = z2^2^2 */ +/* asm 1: fe_sq(>z8=fe#2,z8=fe#2,>z8=fe#2); */ +/* asm 2: fe_sq(>z8=t1,z8=t1,>z8=t1); */ +fe_sq(t1,t0); for (i = 1;i < 2;++i) fe_sq(t1,t1); + +/* qhasm: z9 = z1*z8 */ +/* asm 1: fe_mul(>z9=fe#2,z9=t1,z11=fe#1,z11=t0,z22=fe#3,z22=fe#3,>z22=fe#3); */ +/* asm 2: fe_sq(>z22=t2,z22=t2,>z22=t2); */ +fe_sq(t2,t0); for (i = 1;i < 1;++i) fe_sq(t2,t2); + +/* qhasm: z_5_0 = z9*z22 */ +/* asm 1: fe_mul(>z_5_0=fe#2,z_5_0=t1,z_10_5=fe#3,z_10_5=fe#3,>z_10_5=fe#3); */ +/* asm 2: fe_sq(>z_10_5=t2,z_10_5=t2,>z_10_5=t2); */ +fe_sq(t2,t1); for (i = 1;i < 5;++i) fe_sq(t2,t2); + +/* qhasm: z_10_0 = z_10_5*z_5_0 */ +/* asm 1: fe_mul(>z_10_0=fe#2,z_10_0=t1,z_20_10=fe#3,z_20_10=fe#3,>z_20_10=fe#3); */ +/* asm 2: fe_sq(>z_20_10=t2,z_20_10=t2,>z_20_10=t2); */ +fe_sq(t2,t1); for (i = 1;i < 10;++i) fe_sq(t2,t2); + +/* qhasm: z_20_0 = z_20_10*z_10_0 */ +/* asm 1: fe_mul(>z_20_0=fe#3,z_20_0=t2,z_40_20=fe#4,z_40_20=fe#4,>z_40_20=fe#4); */ +/* asm 2: fe_sq(>z_40_20=t3,z_40_20=t3,>z_40_20=t3); */ +fe_sq(t3,t2); for (i = 1;i < 20;++i) fe_sq(t3,t3); + +/* qhasm: z_40_0 = z_40_20*z_20_0 */ +/* asm 1: fe_mul(>z_40_0=fe#3,z_40_0=t2,z_50_10=fe#3,z_50_10=fe#3,>z_50_10=fe#3); */ +/* asm 2: fe_sq(>z_50_10=t2,z_50_10=t2,>z_50_10=t2); */ +fe_sq(t2,t2); for (i = 1;i < 10;++i) fe_sq(t2,t2); + +/* qhasm: z_50_0 = z_50_10*z_10_0 */ +/* asm 1: fe_mul(>z_50_0=fe#2,z_50_0=t1,z_100_50=fe#3,z_100_50=fe#3,>z_100_50=fe#3); */ +/* asm 2: fe_sq(>z_100_50=t2,z_100_50=t2,>z_100_50=t2); */ +fe_sq(t2,t1); for (i = 1;i < 50;++i) fe_sq(t2,t2); + +/* qhasm: z_100_0 = z_100_50*z_50_0 */ +/* asm 1: fe_mul(>z_100_0=fe#3,z_100_0=t2,z_200_100=fe#4,z_200_100=fe#4,>z_200_100=fe#4); */ +/* asm 2: fe_sq(>z_200_100=t3,z_200_100=t3,>z_200_100=t3); */ +fe_sq(t3,t2); for (i = 1;i < 100;++i) fe_sq(t3,t3); + +/* qhasm: z_200_0 = z_200_100*z_100_0 */ +/* asm 1: fe_mul(>z_200_0=fe#3,z_200_0=t2,z_250_50=fe#3,z_250_50=fe#3,>z_250_50=fe#3); */ +/* asm 2: fe_sq(>z_250_50=t2,z_250_50=t2,>z_250_50=t2); */ +fe_sq(t2,t2); for (i = 1;i < 50;++i) fe_sq(t2,t2); + +/* qhasm: z_250_0 = z_250_50*z_50_0 */ +/* asm 1: fe_mul(>z_250_0=fe#2,z_250_0=t1,z_255_5=fe#2,z_255_5=fe#2,>z_255_5=fe#2); */ +/* asm 2: fe_sq(>z_255_5=t1,z_255_5=t1,>z_255_5=t1); */ +fe_sq(t1,t1); for (i = 1;i < 5;++i) fe_sq(t1,t1); + +/* qhasm: z_255_21 = z_255_5*z11 */ +/* asm 1: fe_mul(>z_255_21=fe#12,z_255_21=out, +#include "randombytes.h" +#include "ed25519.h" +#include "sha512.h" +#include "ge.h" + +int ed25519_sign_seed_keypair(unsigned char *pk, unsigned char *sk, + const unsigned char *seed) +{ + ge_p3 A; + + crypto_hash_sha512(sk,seed,32); + sk[0] &= 248; + sk[31] &= 63; + sk[31] |= 64; + + ge_scalarmult_base(&A,sk); + ge_p3_tobytes(pk,&A); + + memmove(sk, seed, 32); + memmove(sk + 32, pk, 32); + return 0; +} + +int ed25519_sign_keypair(unsigned char *pk, unsigned char *sk) +{ + unsigned char seed[32]; + int ret; + + ed25519_randombytes(seed, sizeof seed); + ret = ed25519_sign_seed_keypair(pk, sk, seed); + memset(seed, 0, sizeof seed); + + return ret; +} diff --git a/bundled/cbits/ref10/open.c b/bundled/cbits/ref10/open.c new file mode 100644 index 0000000..8715378 --- /dev/null +++ b/bundled/cbits/ref10/open.c @@ -0,0 +1,40 @@ +#include "ed25519.h" +#include "sha512.h" +#include "crypto_verify.h" +#include "ge.h" +#include "sc.h" + +int ed25519_sign_open( + unsigned char *m,unsigned long long *mlen, + const unsigned char *sm,unsigned long long smlen, + const unsigned char *pk +) +{ + unsigned char h[64]; + unsigned char checkr[32]; + ge_p3 A; + ge_p2 R; + unsigned long long i; + + *mlen = -1; + if (smlen < 64) return -1; + if (sm[63] & 224) return -1; + if (ge_frombytes_negate_vartime(&A,pk) != 0) return -1; + + for (i = 0;i < smlen;++i) m[i] = sm[i]; + for (i = 0;i < 32;++i) m[32 + i] = pk[i]; + crypto_hash_sha512(h,m,smlen); + sc_reduce(h); + + ge_double_scalarmult_vartime(&R,h,&A,sm + 32); + ge_tobytes(checkr,&R); + if (crypto_verify_32(checkr,sm) != 0) { + for (i = 0;i < smlen;++i) m[i] = 0; + return -1; + } + + for (i = 0;i < smlen - 64;++i) m[i] = sm[64 + i]; + for (i = smlen - 64;i < smlen;++i) m[i] = 0; + *mlen = smlen - 64; + return 0; +} diff --git a/bundled/cbits/ref10/randombytes.c b/bundled/cbits/ref10/randombytes.c new file mode 100644 index 0000000..fa7d421 --- /dev/null +++ b/bundled/cbits/ref10/randombytes.c @@ -0,0 +1,52 @@ +#ifndef _WIN32 +#include +#include +#include +#include + +/* it's really stupid that there isn't a syscall for this */ + +static int ed25519_random_fd = -1; + +static inline void ed25519_randombytes(unsigned char *x,unsigned long long xlen) +{ + int i; + + if (ed25519_random_fd == -1) { + for (;;) { + ed25519_random_fd = open("/dev/urandom",O_RDONLY); + if (ed25519_random_fd != -1) break; + sleep(1); + } + } + + while (xlen > 0) { + if (xlen < 1048576) i = xlen; else i = 1048576; + + i = read(ed25519_random_fd,x,i); + if (i < 1) { + sleep(1); + continue; + } + + x += i; + xlen -= i; + } +} + +#else +#include +#include + +static inline void ed25519_randombytes(unsigned char *x,unsigned long long xlen) +{ + HCRYPTPROV prov = 0; + + CryptAcquireContextW(&prov, NULL, NULL, + PROV_RSA_FULL, CRYPT_VERIFYCONTEXT | CRYPT_SILENT); + + CryptGenRandom(prov, xlen, x); + CryptReleaseContext(prov, 0); +} + +#endif /* _WIN32 */ diff --git a/bundled/cbits/ref10/sc_muladd.c b/bundled/cbits/ref10/sc_muladd.c new file mode 100644 index 0000000..450f77b --- /dev/null +++ b/bundled/cbits/ref10/sc_muladd.c @@ -0,0 +1,350 @@ +#include "sc.h" +#include "load.h" +#include "crypto_int64.h" +#include "crypto_uint32.h" +#include "crypto_uint64.h" + +/* +Input: + a[0]+256*a[1]+...+256^31*a[31] = a + b[0]+256*b[1]+...+256^31*b[31] = b + c[0]+256*c[1]+...+256^31*c[31] = c + +Output: + s[0]+256*s[1]+...+256^31*s[31] = (ab+c) mod l + where l = 2^252 + 27742317777372353535851937790883648493. +*/ + +static inline void sc_muladd(unsigned char *s,const unsigned char *a,const unsigned char *b,const unsigned char *c) +{ + crypto_int64 a0 = 2097151 & load_3(a); + crypto_int64 a1 = 2097151 & (load_4(a + 2) >> 5); + crypto_int64 a2 = 2097151 & (load_3(a + 5) >> 2); + crypto_int64 a3 = 2097151 & (load_4(a + 7) >> 7); + crypto_int64 a4 = 2097151 & (load_4(a + 10) >> 4); + crypto_int64 a5 = 2097151 & (load_3(a + 13) >> 1); + crypto_int64 a6 = 2097151 & (load_4(a + 15) >> 6); + crypto_int64 a7 = 2097151 & (load_3(a + 18) >> 3); + crypto_int64 a8 = 2097151 & load_3(a + 21); + crypto_int64 a9 = 2097151 & (load_4(a + 23) >> 5); + crypto_int64 a10 = 2097151 & (load_3(a + 26) >> 2); + crypto_int64 a11 = (load_4(a + 28) >> 7); + crypto_int64 b0 = 2097151 & load_3(b); + crypto_int64 b1 = 2097151 & (load_4(b + 2) >> 5); + crypto_int64 b2 = 2097151 & (load_3(b + 5) >> 2); + crypto_int64 b3 = 2097151 & (load_4(b + 7) >> 7); + crypto_int64 b4 = 2097151 & (load_4(b + 10) >> 4); + crypto_int64 b5 = 2097151 & (load_3(b + 13) >> 1); + crypto_int64 b6 = 2097151 & (load_4(b + 15) >> 6); + crypto_int64 b7 = 2097151 & (load_3(b + 18) >> 3); + crypto_int64 b8 = 2097151 & load_3(b + 21); + crypto_int64 b9 = 2097151 & (load_4(b + 23) >> 5); + crypto_int64 b10 = 2097151 & (load_3(b + 26) >> 2); + crypto_int64 b11 = (load_4(b + 28) >> 7); + crypto_int64 c0 = 2097151 & load_3(c); + crypto_int64 c1 = 2097151 & (load_4(c + 2) >> 5); + crypto_int64 c2 = 2097151 & (load_3(c + 5) >> 2); + crypto_int64 c3 = 2097151 & (load_4(c + 7) >> 7); + crypto_int64 c4 = 2097151 & (load_4(c + 10) >> 4); + crypto_int64 c5 = 2097151 & (load_3(c + 13) >> 1); + crypto_int64 c6 = 2097151 & (load_4(c + 15) >> 6); + crypto_int64 c7 = 2097151 & (load_3(c + 18) >> 3); + crypto_int64 c8 = 2097151 & load_3(c + 21); + crypto_int64 c9 = 2097151 & (load_4(c + 23) >> 5); + crypto_int64 c10 = 2097151 & (load_3(c + 26) >> 2); + crypto_int64 c11 = (load_4(c + 28) >> 7); + crypto_int64 s0; + crypto_int64 s1; + crypto_int64 s2; + crypto_int64 s3; + crypto_int64 s4; + crypto_int64 s5; + crypto_int64 s6; + crypto_int64 s7; + crypto_int64 s8; + crypto_int64 s9; + crypto_int64 s10; + crypto_int64 s11; + crypto_int64 s12; + crypto_int64 s13; + crypto_int64 s14; + crypto_int64 s15; + crypto_int64 s16; + crypto_int64 s17; + crypto_int64 s18; + crypto_int64 s19; + crypto_int64 s20; + crypto_int64 s21; + crypto_int64 s22; + crypto_int64 s23; + crypto_int64 carry0; + crypto_int64 carry1; + crypto_int64 carry2; + crypto_int64 carry3; + crypto_int64 carry4; + crypto_int64 carry5; + crypto_int64 carry6; + crypto_int64 carry7; + crypto_int64 carry8; + crypto_int64 carry9; + crypto_int64 carry10; + crypto_int64 carry11; + crypto_int64 carry12; + crypto_int64 carry13; + crypto_int64 carry14; + crypto_int64 carry15; + crypto_int64 carry16; + crypto_int64 carry17; + crypto_int64 carry18; + crypto_int64 carry19; + crypto_int64 carry20; + crypto_int64 carry21; + crypto_int64 carry22; + + s0 = c0 + a0*b0; + s1 = c1 + a0*b1 + a1*b0; + s2 = c2 + a0*b2 + a1*b1 + a2*b0; + s3 = c3 + a0*b3 + a1*b2 + a2*b1 + a3*b0; + s4 = c4 + a0*b4 + a1*b3 + a2*b2 + a3*b1 + a4*b0; + s5 = c5 + a0*b5 + a1*b4 + a2*b3 + a3*b2 + a4*b1 + a5*b0; + s6 = c6 + a0*b6 + a1*b5 + a2*b4 + a3*b3 + a4*b2 + a5*b1 + a6*b0; + s7 = c7 + a0*b7 + a1*b6 + a2*b5 + a3*b4 + a4*b3 + a5*b2 + a6*b1 + a7*b0; + s8 = c8 + a0*b8 + a1*b7 + a2*b6 + a3*b5 + a4*b4 + a5*b3 + a6*b2 + a7*b1 + a8*b0; + s9 = c9 + a0*b9 + a1*b8 + a2*b7 + a3*b6 + a4*b5 + a5*b4 + a6*b3 + a7*b2 + a8*b1 + a9*b0; + s10 = c10 + a0*b10 + a1*b9 + a2*b8 + a3*b7 + a4*b6 + a5*b5 + a6*b4 + a7*b3 + a8*b2 + a9*b1 + a10*b0; + s11 = c11 + a0*b11 + a1*b10 + a2*b9 + a3*b8 + a4*b7 + a5*b6 + a6*b5 + a7*b4 + a8*b3 + a9*b2 + a10*b1 + a11*b0; + s12 = a1*b11 + a2*b10 + a3*b9 + a4*b8 + a5*b7 + a6*b6 + a7*b5 + a8*b4 + a9*b3 + a10*b2 + a11*b1; + s13 = a2*b11 + a3*b10 + a4*b9 + a5*b8 + a6*b7 + a7*b6 + a8*b5 + a9*b4 + a10*b3 + a11*b2; + s14 = a3*b11 + a4*b10 + a5*b9 + a6*b8 + a7*b7 + a8*b6 + a9*b5 + a10*b4 + a11*b3; + s15 = a4*b11 + a5*b10 + a6*b9 + a7*b8 + a8*b7 + a9*b6 + a10*b5 + a11*b4; + s16 = a5*b11 + a6*b10 + a7*b9 + a8*b8 + a9*b7 + a10*b6 + a11*b5; + s17 = a6*b11 + a7*b10 + a8*b9 + a9*b8 + a10*b7 + a11*b6; + s18 = a7*b11 + a8*b10 + a9*b9 + a10*b8 + a11*b7; + s19 = a8*b11 + a9*b10 + a10*b9 + a11*b8; + s20 = a9*b11 + a10*b10 + a11*b9; + s21 = a10*b11 + a11*b10; + s22 = a11*b11; + s23 = 0; + + carry0 = (s0 + (1<<20)) >> 21; s1 += carry0; s0 -= carry0 << 21; + carry2 = (s2 + (1<<20)) >> 21; s3 += carry2; s2 -= carry2 << 21; + carry4 = (s4 + (1<<20)) >> 21; s5 += carry4; s4 -= carry4 << 21; + carry6 = (s6 + (1<<20)) >> 21; s7 += carry6; s6 -= carry6 << 21; + carry8 = (s8 + (1<<20)) >> 21; s9 += carry8; s8 -= carry8 << 21; + carry10 = (s10 + (1<<20)) >> 21; s11 += carry10; s10 -= carry10 << 21; + carry12 = (s12 + (1<<20)) >> 21; s13 += carry12; s12 -= carry12 << 21; + carry14 = (s14 + (1<<20)) >> 21; s15 += carry14; s14 -= carry14 << 21; + carry16 = (s16 + (1<<20)) >> 21; s17 += carry16; s16 -= carry16 << 21; + carry18 = (s18 + (1<<20)) >> 21; s19 += carry18; s18 -= carry18 << 21; + carry20 = (s20 + (1<<20)) >> 21; s21 += carry20; s20 -= carry20 << 21; + carry22 = (s22 + (1<<20)) >> 21; s23 += carry22; s22 -= carry22 << 21; + + carry1 = (s1 + (1<<20)) >> 21; s2 += carry1; s1 -= carry1 << 21; + carry3 = (s3 + (1<<20)) >> 21; s4 += carry3; s3 -= carry3 << 21; + carry5 = (s5 + (1<<20)) >> 21; s6 += carry5; s5 -= carry5 << 21; + carry7 = (s7 + (1<<20)) >> 21; s8 += carry7; s7 -= carry7 << 21; + carry9 = (s9 + (1<<20)) >> 21; s10 += carry9; s9 -= carry9 << 21; + carry11 = (s11 + (1<<20)) >> 21; s12 += carry11; s11 -= carry11 << 21; + carry13 = (s13 + (1<<20)) >> 21; s14 += carry13; s13 -= carry13 << 21; + carry15 = (s15 + (1<<20)) >> 21; s16 += carry15; s15 -= carry15 << 21; + carry17 = (s17 + (1<<20)) >> 21; s18 += carry17; s17 -= carry17 << 21; + carry19 = (s19 + (1<<20)) >> 21; s20 += carry19; s19 -= carry19 << 21; + carry21 = (s21 + (1<<20)) >> 21; s22 += carry21; s21 -= carry21 << 21; + + s11 += s23 * 666643; + s12 += s23 * 470296; + s13 += s23 * 654183; + s14 -= s23 * 997805; + s15 += s23 * 136657; + s16 -= s23 * 683901; + s23 = 0; + + s10 += s22 * 666643; + s11 += s22 * 470296; + s12 += s22 * 654183; + s13 -= s22 * 997805; + s14 += s22 * 136657; + s15 -= s22 * 683901; + s22 = 0; + + s9 += s21 * 666643; + s10 += s21 * 470296; + s11 += s21 * 654183; + s12 -= s21 * 997805; + s13 += s21 * 136657; + s14 -= s21 * 683901; + s21 = 0; + + s8 += s20 * 666643; + s9 += s20 * 470296; + s10 += s20 * 654183; + s11 -= s20 * 997805; + s12 += s20 * 136657; + s13 -= s20 * 683901; + s20 = 0; + + s7 += s19 * 666643; + s8 += s19 * 470296; + s9 += s19 * 654183; + s10 -= s19 * 997805; + s11 += s19 * 136657; + s12 -= s19 * 683901; + s19 = 0; + + s6 += s18 * 666643; + s7 += s18 * 470296; + s8 += s18 * 654183; + s9 -= s18 * 997805; + s10 += s18 * 136657; + s11 -= s18 * 683901; + s18 = 0; + + carry6 = (s6 + (1<<20)) >> 21; s7 += carry6; s6 -= carry6 << 21; + carry8 = (s8 + (1<<20)) >> 21; s9 += carry8; s8 -= carry8 << 21; + carry10 = (s10 + (1<<20)) >> 21; s11 += carry10; s10 -= carry10 << 21; + carry12 = (s12 + (1<<20)) >> 21; s13 += carry12; s12 -= carry12 << 21; + carry14 = (s14 + (1<<20)) >> 21; s15 += carry14; s14 -= carry14 << 21; + carry16 = (s16 + (1<<20)) >> 21; s17 += carry16; s16 -= carry16 << 21; + + carry7 = (s7 + (1<<20)) >> 21; s8 += carry7; s7 -= carry7 << 21; + carry9 = (s9 + (1<<20)) >> 21; s10 += carry9; s9 -= carry9 << 21; + carry11 = (s11 + (1<<20)) >> 21; s12 += carry11; s11 -= carry11 << 21; + carry13 = (s13 + (1<<20)) >> 21; s14 += carry13; s13 -= carry13 << 21; + carry15 = (s15 + (1<<20)) >> 21; s16 += carry15; s15 -= carry15 << 21; + + s5 += s17 * 666643; + s6 += s17 * 470296; + s7 += s17 * 654183; + s8 -= s17 * 997805; + s9 += s17 * 136657; + s10 -= s17 * 683901; + s17 = 0; + + s4 += s16 * 666643; + s5 += s16 * 470296; + s6 += s16 * 654183; + s7 -= s16 * 997805; + s8 += s16 * 136657; + s9 -= s16 * 683901; + s16 = 0; + + s3 += s15 * 666643; + s4 += s15 * 470296; + s5 += s15 * 654183; + s6 -= s15 * 997805; + s7 += s15 * 136657; + s8 -= s15 * 683901; + s15 = 0; + + s2 += s14 * 666643; + s3 += s14 * 470296; + s4 += s14 * 654183; + s5 -= s14 * 997805; + s6 += s14 * 136657; + s7 -= s14 * 683901; + s14 = 0; + + s1 += s13 * 666643; + s2 += s13 * 470296; + s3 += s13 * 654183; + s4 -= s13 * 997805; + s5 += s13 * 136657; + s6 -= s13 * 683901; + s13 = 0; + + s0 += s12 * 666643; + s1 += s12 * 470296; + s2 += s12 * 654183; + s3 -= s12 * 997805; + s4 += s12 * 136657; + s5 -= s12 * 683901; + s12 = 0; + + carry0 = (s0 + (1<<20)) >> 21; s1 += carry0; s0 -= carry0 << 21; + carry2 = (s2 + (1<<20)) >> 21; s3 += carry2; s2 -= carry2 << 21; + carry4 = (s4 + (1<<20)) >> 21; s5 += carry4; s4 -= carry4 << 21; + carry6 = (s6 + (1<<20)) >> 21; s7 += carry6; s6 -= carry6 << 21; + carry8 = (s8 + (1<<20)) >> 21; s9 += carry8; s8 -= carry8 << 21; + carry10 = (s10 + (1<<20)) >> 21; s11 += carry10; s10 -= carry10 << 21; + + carry1 = (s1 + (1<<20)) >> 21; s2 += carry1; s1 -= carry1 << 21; + carry3 = (s3 + (1<<20)) >> 21; s4 += carry3; s3 -= carry3 << 21; + carry5 = (s5 + (1<<20)) >> 21; s6 += carry5; s5 -= carry5 << 21; + carry7 = (s7 + (1<<20)) >> 21; s8 += carry7; s7 -= carry7 << 21; + carry9 = (s9 + (1<<20)) >> 21; s10 += carry9; s9 -= carry9 << 21; + carry11 = (s11 + (1<<20)) >> 21; s12 += carry11; s11 -= carry11 << 21; + + s0 += s12 * 666643; + s1 += s12 * 470296; + s2 += s12 * 654183; + s3 -= s12 * 997805; + s4 += s12 * 136657; + s5 -= s12 * 683901; + s12 = 0; + + carry0 = s0 >> 21; s1 += carry0; s0 -= carry0 << 21; + carry1 = s1 >> 21; s2 += carry1; s1 -= carry1 << 21; + carry2 = s2 >> 21; s3 += carry2; s2 -= carry2 << 21; + carry3 = s3 >> 21; s4 += carry3; s3 -= carry3 << 21; + carry4 = s4 >> 21; s5 += carry4; s4 -= carry4 << 21; + carry5 = s5 >> 21; s6 += carry5; s5 -= carry5 << 21; + carry6 = s6 >> 21; s7 += carry6; s6 -= carry6 << 21; + carry7 = s7 >> 21; s8 += carry7; s7 -= carry7 << 21; + carry8 = s8 >> 21; s9 += carry8; s8 -= carry8 << 21; + carry9 = s9 >> 21; s10 += carry9; s9 -= carry9 << 21; + carry10 = s10 >> 21; s11 += carry10; s10 -= carry10 << 21; + carry11 = s11 >> 21; s12 += carry11; s11 -= carry11 << 21; + + s0 += s12 * 666643; + s1 += s12 * 470296; + s2 += s12 * 654183; + s3 -= s12 * 997805; + s4 += s12 * 136657; + s5 -= s12 * 683901; + s12 = 0; + + carry0 = s0 >> 21; s1 += carry0; s0 -= carry0 << 21; + carry1 = s1 >> 21; s2 += carry1; s1 -= carry1 << 21; + carry2 = s2 >> 21; s3 += carry2; s2 -= carry2 << 21; + carry3 = s3 >> 21; s4 += carry3; s3 -= carry3 << 21; + carry4 = s4 >> 21; s5 += carry4; s4 -= carry4 << 21; + carry5 = s5 >> 21; s6 += carry5; s5 -= carry5 << 21; + carry6 = s6 >> 21; s7 += carry6; s6 -= carry6 << 21; + carry7 = s7 >> 21; s8 += carry7; s7 -= carry7 << 21; + carry8 = s8 >> 21; s9 += carry8; s8 -= carry8 << 21; + carry9 = s9 >> 21; s10 += carry9; s9 -= carry9 << 21; + carry10 = s10 >> 21; s11 += carry10; s10 -= carry10 << 21; + + s[0] = s0 >> 0; + s[1] = s0 >> 8; + s[2] = (s0 >> 16) | (s1 << 5); + s[3] = s1 >> 3; + s[4] = s1 >> 11; + s[5] = (s1 >> 19) | (s2 << 2); + s[6] = s2 >> 6; + s[7] = (s2 >> 14) | (s3 << 7); + s[8] = s3 >> 1; + s[9] = s3 >> 9; + s[10] = (s3 >> 17) | (s4 << 4); + s[11] = s4 >> 4; + s[12] = s4 >> 12; + s[13] = (s4 >> 20) | (s5 << 1); + s[14] = s5 >> 7; + s[15] = (s5 >> 15) | (s6 << 6); + s[16] = s6 >> 2; + s[17] = s6 >> 10; + s[18] = (s6 >> 18) | (s7 << 3); + s[19] = s7 >> 5; + s[20] = s7 >> 13; + s[21] = s8 >> 0; + s[22] = s8 >> 8; + s[23] = (s8 >> 16) | (s9 << 5); + s[24] = s9 >> 3; + s[25] = s9 >> 11; + s[26] = (s9 >> 19) | (s10 << 2); + s[27] = s10 >> 6; + s[28] = (s10 >> 14) | (s11 << 7); + s[29] = s11 >> 1; + s[30] = s11 >> 9; + s[31] = s11 >> 17; +} diff --git a/bundled/cbits/ref10/sc_reduce.c b/bundled/cbits/ref10/sc_reduce.c new file mode 100644 index 0000000..6448b2f --- /dev/null +++ b/bundled/cbits/ref10/sc_reduce.c @@ -0,0 +1,257 @@ +#include "sc.h" +#include "load.h" +#include "crypto_int64.h" +#include "crypto_uint32.h" +#include "crypto_uint64.h" + +/* +Input: + s[0]+256*s[1]+...+256^63*s[63] = s + +Output: + s[0]+256*s[1]+...+256^31*s[31] = s mod l + where l = 2^252 + 27742317777372353535851937790883648493. + Overwrites s in place. +*/ + +static inline void sc_reduce(unsigned char *s) +{ + crypto_int64 s0 = 2097151 & load_3(s); + crypto_int64 s1 = 2097151 & (load_4(s + 2) >> 5); + crypto_int64 s2 = 2097151 & (load_3(s + 5) >> 2); + crypto_int64 s3 = 2097151 & (load_4(s + 7) >> 7); + crypto_int64 s4 = 2097151 & (load_4(s + 10) >> 4); + crypto_int64 s5 = 2097151 & (load_3(s + 13) >> 1); + crypto_int64 s6 = 2097151 & (load_4(s + 15) >> 6); + crypto_int64 s7 = 2097151 & (load_3(s + 18) >> 3); + crypto_int64 s8 = 2097151 & load_3(s + 21); + crypto_int64 s9 = 2097151 & (load_4(s + 23) >> 5); + crypto_int64 s10 = 2097151 & (load_3(s + 26) >> 2); + crypto_int64 s11 = 2097151 & (load_4(s + 28) >> 7); + crypto_int64 s12 = 2097151 & (load_4(s + 31) >> 4); + crypto_int64 s13 = 2097151 & (load_3(s + 34) >> 1); + crypto_int64 s14 = 2097151 & (load_4(s + 36) >> 6); + crypto_int64 s15 = 2097151 & (load_3(s + 39) >> 3); + crypto_int64 s16 = 2097151 & load_3(s + 42); + crypto_int64 s17 = 2097151 & (load_4(s + 44) >> 5); + crypto_int64 s18 = 2097151 & (load_3(s + 47) >> 2); + crypto_int64 s19 = 2097151 & (load_4(s + 49) >> 7); + crypto_int64 s20 = 2097151 & (load_4(s + 52) >> 4); + crypto_int64 s21 = 2097151 & (load_3(s + 55) >> 1); + crypto_int64 s22 = 2097151 & (load_4(s + 57) >> 6); + crypto_int64 s23 = (load_4(s + 60) >> 3); + crypto_int64 carry0; + crypto_int64 carry1; + crypto_int64 carry2; + crypto_int64 carry3; + crypto_int64 carry4; + crypto_int64 carry5; + crypto_int64 carry6; + crypto_int64 carry7; + crypto_int64 carry8; + crypto_int64 carry9; + crypto_int64 carry10; + crypto_int64 carry11; + crypto_int64 carry12; + crypto_int64 carry13; + crypto_int64 carry14; + crypto_int64 carry15; + crypto_int64 carry16; + + s11 += s23 * 666643; + s12 += s23 * 470296; + s13 += s23 * 654183; + s14 -= s23 * 997805; + s15 += s23 * 136657; + s16 -= s23 * 683901; + s23 = 0; + + s10 += s22 * 666643; + s11 += s22 * 470296; + s12 += s22 * 654183; + s13 -= s22 * 997805; + s14 += s22 * 136657; + s15 -= s22 * 683901; + s22 = 0; + + s9 += s21 * 666643; + s10 += s21 * 470296; + s11 += s21 * 654183; + s12 -= s21 * 997805; + s13 += s21 * 136657; + s14 -= s21 * 683901; + s21 = 0; + + s8 += s20 * 666643; + s9 += s20 * 470296; + s10 += s20 * 654183; + s11 -= s20 * 997805; + s12 += s20 * 136657; + s13 -= s20 * 683901; + s20 = 0; + + s7 += s19 * 666643; + s8 += s19 * 470296; + s9 += s19 * 654183; + s10 -= s19 * 997805; + s11 += s19 * 136657; + s12 -= s19 * 683901; + s19 = 0; + + s6 += s18 * 666643; + s7 += s18 * 470296; + s8 += s18 * 654183; + s9 -= s18 * 997805; + s10 += s18 * 136657; + s11 -= s18 * 683901; + s18 = 0; + + carry6 = (s6 + (1<<20)) >> 21; s7 += carry6; s6 -= carry6 << 21; + carry8 = (s8 + (1<<20)) >> 21; s9 += carry8; s8 -= carry8 << 21; + carry10 = (s10 + (1<<20)) >> 21; s11 += carry10; s10 -= carry10 << 21; + carry12 = (s12 + (1<<20)) >> 21; s13 += carry12; s12 -= carry12 << 21; + carry14 = (s14 + (1<<20)) >> 21; s15 += carry14; s14 -= carry14 << 21; + carry16 = (s16 + (1<<20)) >> 21; s17 += carry16; s16 -= carry16 << 21; + + carry7 = (s7 + (1<<20)) >> 21; s8 += carry7; s7 -= carry7 << 21; + carry9 = (s9 + (1<<20)) >> 21; s10 += carry9; s9 -= carry9 << 21; + carry11 = (s11 + (1<<20)) >> 21; s12 += carry11; s11 -= carry11 << 21; + carry13 = (s13 + (1<<20)) >> 21; s14 += carry13; s13 -= carry13 << 21; + carry15 = (s15 + (1<<20)) >> 21; s16 += carry15; s15 -= carry15 << 21; + + s5 += s17 * 666643; + s6 += s17 * 470296; + s7 += s17 * 654183; + s8 -= s17 * 997805; + s9 += s17 * 136657; + s10 -= s17 * 683901; + s17 = 0; + + s4 += s16 * 666643; + s5 += s16 * 470296; + s6 += s16 * 654183; + s7 -= s16 * 997805; + s8 += s16 * 136657; + s9 -= s16 * 683901; + s16 = 0; + + s3 += s15 * 666643; + s4 += s15 * 470296; + s5 += s15 * 654183; + s6 -= s15 * 997805; + s7 += s15 * 136657; + s8 -= s15 * 683901; + s15 = 0; + + s2 += s14 * 666643; + s3 += s14 * 470296; + s4 += s14 * 654183; + s5 -= s14 * 997805; + s6 += s14 * 136657; + s7 -= s14 * 683901; + s14 = 0; + + s1 += s13 * 666643; + s2 += s13 * 470296; + s3 += s13 * 654183; + s4 -= s13 * 997805; + s5 += s13 * 136657; + s6 -= s13 * 683901; + s13 = 0; + + s0 += s12 * 666643; + s1 += s12 * 470296; + s2 += s12 * 654183; + s3 -= s12 * 997805; + s4 += s12 * 136657; + s5 -= s12 * 683901; + s12 = 0; + + carry0 = (s0 + (1<<20)) >> 21; s1 += carry0; s0 -= carry0 << 21; + carry2 = (s2 + (1<<20)) >> 21; s3 += carry2; s2 -= carry2 << 21; + carry4 = (s4 + (1<<20)) >> 21; s5 += carry4; s4 -= carry4 << 21; + carry6 = (s6 + (1<<20)) >> 21; s7 += carry6; s6 -= carry6 << 21; + carry8 = (s8 + (1<<20)) >> 21; s9 += carry8; s8 -= carry8 << 21; + carry10 = (s10 + (1<<20)) >> 21; s11 += carry10; s10 -= carry10 << 21; + + carry1 = (s1 + (1<<20)) >> 21; s2 += carry1; s1 -= carry1 << 21; + carry3 = (s3 + (1<<20)) >> 21; s4 += carry3; s3 -= carry3 << 21; + carry5 = (s5 + (1<<20)) >> 21; s6 += carry5; s5 -= carry5 << 21; + carry7 = (s7 + (1<<20)) >> 21; s8 += carry7; s7 -= carry7 << 21; + carry9 = (s9 + (1<<20)) >> 21; s10 += carry9; s9 -= carry9 << 21; + carry11 = (s11 + (1<<20)) >> 21; s12 += carry11; s11 -= carry11 << 21; + + s0 += s12 * 666643; + s1 += s12 * 470296; + s2 += s12 * 654183; + s3 -= s12 * 997805; + s4 += s12 * 136657; + s5 -= s12 * 683901; + s12 = 0; + + carry0 = s0 >> 21; s1 += carry0; s0 -= carry0 << 21; + carry1 = s1 >> 21; s2 += carry1; s1 -= carry1 << 21; + carry2 = s2 >> 21; s3 += carry2; s2 -= carry2 << 21; + carry3 = s3 >> 21; s4 += carry3; s3 -= carry3 << 21; + carry4 = s4 >> 21; s5 += carry4; s4 -= carry4 << 21; + carry5 = s5 >> 21; s6 += carry5; s5 -= carry5 << 21; + carry6 = s6 >> 21; s7 += carry6; s6 -= carry6 << 21; + carry7 = s7 >> 21; s8 += carry7; s7 -= carry7 << 21; + carry8 = s8 >> 21; s9 += carry8; s8 -= carry8 << 21; + carry9 = s9 >> 21; s10 += carry9; s9 -= carry9 << 21; + carry10 = s10 >> 21; s11 += carry10; s10 -= carry10 << 21; + carry11 = s11 >> 21; s12 += carry11; s11 -= carry11 << 21; + + s0 += s12 * 666643; + s1 += s12 * 470296; + s2 += s12 * 654183; + s3 -= s12 * 997805; + s4 += s12 * 136657; + s5 -= s12 * 683901; + s12 = 0; + + carry0 = s0 >> 21; s1 += carry0; s0 -= carry0 << 21; + carry1 = s1 >> 21; s2 += carry1; s1 -= carry1 << 21; + carry2 = s2 >> 21; s3 += carry2; s2 -= carry2 << 21; + carry3 = s3 >> 21; s4 += carry3; s3 -= carry3 << 21; + carry4 = s4 >> 21; s5 += carry4; s4 -= carry4 << 21; + carry5 = s5 >> 21; s6 += carry5; s5 -= carry5 << 21; + carry6 = s6 >> 21; s7 += carry6; s6 -= carry6 << 21; + carry7 = s7 >> 21; s8 += carry7; s7 -= carry7 << 21; + carry8 = s8 >> 21; s9 += carry8; s8 -= carry8 << 21; + carry9 = s9 >> 21; s10 += carry9; s9 -= carry9 << 21; + carry10 = s10 >> 21; s11 += carry10; s10 -= carry10 << 21; + + s[0] = s0 >> 0; + s[1] = s0 >> 8; + s[2] = (s0 >> 16) | (s1 << 5); + s[3] = s1 >> 3; + s[4] = s1 >> 11; + s[5] = (s1 >> 19) | (s2 << 2); + s[6] = s2 >> 6; + s[7] = (s2 >> 14) | (s3 << 7); + s[8] = s3 >> 1; + s[9] = s3 >> 9; + s[10] = (s3 >> 17) | (s4 << 4); + s[11] = s4 >> 4; + s[12] = s4 >> 12; + s[13] = (s4 >> 20) | (s5 << 1); + s[14] = s5 >> 7; + s[15] = (s5 >> 15) | (s6 << 6); + s[16] = s6 >> 2; + s[17] = s6 >> 10; + s[18] = (s6 >> 18) | (s7 << 3); + s[19] = s7 >> 5; + s[20] = s7 >> 13; + s[21] = s8 >> 0; + s[22] = s8 >> 8; + s[23] = (s8 >> 16) | (s9 << 5); + s[24] = s9 >> 3; + s[25] = s9 >> 11; + s[26] = (s9 >> 19) | (s10 << 2); + s[27] = s10 >> 6; + s[28] = (s10 >> 14) | (s11 << 7); + s[29] = s11 >> 1; + s[30] = s11 >> 9; + s[31] = s11 >> 17; +} diff --git a/bundled/cbits/ref10/sha512.c b/bundled/cbits/ref10/sha512.c new file mode 100644 index 0000000..0c29a41 --- /dev/null +++ b/bundled/cbits/ref10/sha512.c @@ -0,0 +1,299 @@ +#include "sha512.h" +#include "crypto_uint64.h" + +static inline crypto_uint64 load_bigendian(const unsigned char *x) +{ + return + (crypto_uint64) (x[7]) \ + | (((crypto_uint64) (x[6])) << 8) \ + | (((crypto_uint64) (x[5])) << 16) \ + | (((crypto_uint64) (x[4])) << 24) \ + | (((crypto_uint64) (x[3])) << 32) \ + | (((crypto_uint64) (x[2])) << 40) \ + | (((crypto_uint64) (x[1])) << 48) \ + | (((crypto_uint64) (x[0])) << 56) + ; +} + +static inline void store_bigendian(unsigned char *x,crypto_uint64 u) +{ + x[7] = u; u >>= 8; + x[6] = u; u >>= 8; + x[5] = u; u >>= 8; + x[4] = u; u >>= 8; + x[3] = u; u >>= 8; + x[2] = u; u >>= 8; + x[1] = u; u >>= 8; + x[0] = u; +} + +#define SHR(x,c) ((x) >> (c)) +#define ROTR(x,c) (((x) >> (c)) | ((x) << (64 - (c)))) + +#define Ch(x,y,z) ((x & y) ^ (~x & z)) +#define Maj(x,y,z) ((x & y) ^ (x & z) ^ (y & z)) +#define Sigma0(x) (ROTR(x,28) ^ ROTR(x,34) ^ ROTR(x,39)) +#define Sigma1(x) (ROTR(x,14) ^ ROTR(x,18) ^ ROTR(x,41)) +#define sigma0(x) (ROTR(x, 1) ^ ROTR(x, 8) ^ SHR(x,7)) +#define sigma1(x) (ROTR(x,19) ^ ROTR(x,61) ^ SHR(x,6)) + +#define M(w0,w14,w9,w1) w0 = sigma1(w14) + w9 + sigma0(w1) + w0; + +#define EXPAND \ + M(w0 ,w14,w9 ,w1 ) \ + M(w1 ,w15,w10,w2 ) \ + M(w2 ,w0 ,w11,w3 ) \ + M(w3 ,w1 ,w12,w4 ) \ + M(w4 ,w2 ,w13,w5 ) \ + M(w5 ,w3 ,w14,w6 ) \ + M(w6 ,w4 ,w15,w7 ) \ + M(w7 ,w5 ,w0 ,w8 ) \ + M(w8 ,w6 ,w1 ,w9 ) \ + M(w9 ,w7 ,w2 ,w10) \ + M(w10,w8 ,w3 ,w11) \ + M(w11,w9 ,w4 ,w12) \ + M(w12,w10,w5 ,w13) \ + M(w13,w11,w6 ,w14) \ + M(w14,w12,w7 ,w15) \ + M(w15,w13,w8 ,w0 ) + +#define F(w,k) \ + T1 = h + Sigma1(e) + Ch(e,f,g) + k + w; \ + T2 = Sigma0(a) + Maj(a,b,c); \ + h = g; \ + g = f; \ + f = e; \ + e = d + T1; \ + d = c; \ + c = b; \ + b = a; \ + a = T1 + T2; + +static inline int crypto_hashblocks_sha512(unsigned char *statebytes,const unsigned char *in,unsigned long long inlen) +{ + crypto_uint64 state[8]; + crypto_uint64 a; + crypto_uint64 b; + crypto_uint64 c; + crypto_uint64 d; + crypto_uint64 e; + crypto_uint64 f; + crypto_uint64 g; + crypto_uint64 h; + crypto_uint64 T1; + crypto_uint64 T2; + + a = load_bigendian(statebytes + 0); state[0] = a; + b = load_bigendian(statebytes + 8); state[1] = b; + c = load_bigendian(statebytes + 16); state[2] = c; + d = load_bigendian(statebytes + 24); state[3] = d; + e = load_bigendian(statebytes + 32); state[4] = e; + f = load_bigendian(statebytes + 40); state[5] = f; + g = load_bigendian(statebytes + 48); state[6] = g; + h = load_bigendian(statebytes + 56); state[7] = h; + + while (inlen >= 128) { + crypto_uint64 w0 = load_bigendian(in + 0); + crypto_uint64 w1 = load_bigendian(in + 8); + crypto_uint64 w2 = load_bigendian(in + 16); + crypto_uint64 w3 = load_bigendian(in + 24); + crypto_uint64 w4 = load_bigendian(in + 32); + crypto_uint64 w5 = load_bigendian(in + 40); + crypto_uint64 w6 = load_bigendian(in + 48); + crypto_uint64 w7 = load_bigendian(in + 56); + crypto_uint64 w8 = load_bigendian(in + 64); + crypto_uint64 w9 = load_bigendian(in + 72); + crypto_uint64 w10 = load_bigendian(in + 80); + crypto_uint64 w11 = load_bigendian(in + 88); + crypto_uint64 w12 = load_bigendian(in + 96); + crypto_uint64 w13 = load_bigendian(in + 104); + crypto_uint64 w14 = load_bigendian(in + 112); + crypto_uint64 w15 = load_bigendian(in + 120); + + F(w0 ,0x428a2f98d728ae22ULL) + F(w1 ,0x7137449123ef65cdULL) + F(w2 ,0xb5c0fbcfec4d3b2fULL) + F(w3 ,0xe9b5dba58189dbbcULL) + F(w4 ,0x3956c25bf348b538ULL) + F(w5 ,0x59f111f1b605d019ULL) + F(w6 ,0x923f82a4af194f9bULL) + F(w7 ,0xab1c5ed5da6d8118ULL) + F(w8 ,0xd807aa98a3030242ULL) + F(w9 ,0x12835b0145706fbeULL) + F(w10,0x243185be4ee4b28cULL) + F(w11,0x550c7dc3d5ffb4e2ULL) + F(w12,0x72be5d74f27b896fULL) + F(w13,0x80deb1fe3b1696b1ULL) + F(w14,0x9bdc06a725c71235ULL) + F(w15,0xc19bf174cf692694ULL) + + EXPAND + + F(w0 ,0xe49b69c19ef14ad2ULL) + F(w1 ,0xefbe4786384f25e3ULL) + F(w2 ,0x0fc19dc68b8cd5b5ULL) + F(w3 ,0x240ca1cc77ac9c65ULL) + F(w4 ,0x2de92c6f592b0275ULL) + F(w5 ,0x4a7484aa6ea6e483ULL) + F(w6 ,0x5cb0a9dcbd41fbd4ULL) + F(w7 ,0x76f988da831153b5ULL) + F(w8 ,0x983e5152ee66dfabULL) + F(w9 ,0xa831c66d2db43210ULL) + F(w10,0xb00327c898fb213fULL) + F(w11,0xbf597fc7beef0ee4ULL) + F(w12,0xc6e00bf33da88fc2ULL) + F(w13,0xd5a79147930aa725ULL) + F(w14,0x06ca6351e003826fULL) + F(w15,0x142929670a0e6e70ULL) + + EXPAND + + F(w0 ,0x27b70a8546d22ffcULL) + F(w1 ,0x2e1b21385c26c926ULL) + F(w2 ,0x4d2c6dfc5ac42aedULL) + F(w3 ,0x53380d139d95b3dfULL) + F(w4 ,0x650a73548baf63deULL) + F(w5 ,0x766a0abb3c77b2a8ULL) + F(w6 ,0x81c2c92e47edaee6ULL) + F(w7 ,0x92722c851482353bULL) + F(w8 ,0xa2bfe8a14cf10364ULL) + F(w9 ,0xa81a664bbc423001ULL) + F(w10,0xc24b8b70d0f89791ULL) + F(w11,0xc76c51a30654be30ULL) + F(w12,0xd192e819d6ef5218ULL) + F(w13,0xd69906245565a910ULL) + F(w14,0xf40e35855771202aULL) + F(w15,0x106aa07032bbd1b8ULL) + + EXPAND + + F(w0 ,0x19a4c116b8d2d0c8ULL) + F(w1 ,0x1e376c085141ab53ULL) + F(w2 ,0x2748774cdf8eeb99ULL) + F(w3 ,0x34b0bcb5e19b48a8ULL) + F(w4 ,0x391c0cb3c5c95a63ULL) + F(w5 ,0x4ed8aa4ae3418acbULL) + F(w6 ,0x5b9cca4f7763e373ULL) + F(w7 ,0x682e6ff3d6b2b8a3ULL) + F(w8 ,0x748f82ee5defb2fcULL) + F(w9 ,0x78a5636f43172f60ULL) + F(w10,0x84c87814a1f0ab72ULL) + F(w11,0x8cc702081a6439ecULL) + F(w12,0x90befffa23631e28ULL) + F(w13,0xa4506cebde82bde9ULL) + F(w14,0xbef9a3f7b2c67915ULL) + F(w15,0xc67178f2e372532bULL) + + EXPAND + + F(w0 ,0xca273eceea26619cULL) + F(w1 ,0xd186b8c721c0c207ULL) + F(w2 ,0xeada7dd6cde0eb1eULL) + F(w3 ,0xf57d4f7fee6ed178ULL) + F(w4 ,0x06f067aa72176fbaULL) + F(w5 ,0x0a637dc5a2c898a6ULL) + F(w6 ,0x113f9804bef90daeULL) + F(w7 ,0x1b710b35131c471bULL) + F(w8 ,0x28db77f523047d84ULL) + F(w9 ,0x32caab7b40c72493ULL) + F(w10,0x3c9ebe0a15c9bebcULL) + F(w11,0x431d67c49c100d4cULL) + F(w12,0x4cc5d4becb3e42b6ULL) + F(w13,0x597f299cfc657e2aULL) + F(w14,0x5fcb6fab3ad6faecULL) + F(w15,0x6c44198c4a475817ULL) + + a += state[0]; + b += state[1]; + c += state[2]; + d += state[3]; + e += state[4]; + f += state[5]; + g += state[6]; + h += state[7]; + + state[0] = a; + state[1] = b; + state[2] = c; + state[3] = d; + state[4] = e; + state[5] = f; + state[6] = g; + state[7] = h; + + in += 128; + inlen -= 128; + } + + store_bigendian(statebytes + 0,state[0]); + store_bigendian(statebytes + 8,state[1]); + store_bigendian(statebytes + 16,state[2]); + store_bigendian(statebytes + 24,state[3]); + store_bigendian(statebytes + 32,state[4]); + store_bigendian(statebytes + 40,state[5]); + store_bigendian(statebytes + 48,state[6]); + store_bigendian(statebytes + 56,state[7]); + + return 0; +} + +#define blocks crypto_hashblocks_sha512 + +static const unsigned char iv[64] = { + 0x6a,0x09,0xe6,0x67,0xf3,0xbc,0xc9,0x08, + 0xbb,0x67,0xae,0x85,0x84,0xca,0xa7,0x3b, + 0x3c,0x6e,0xf3,0x72,0xfe,0x94,0xf8,0x2b, + 0xa5,0x4f,0xf5,0x3a,0x5f,0x1d,0x36,0xf1, + 0x51,0x0e,0x52,0x7f,0xad,0xe6,0x82,0xd1, + 0x9b,0x05,0x68,0x8c,0x2b,0x3e,0x6c,0x1f, + 0x1f,0x83,0xd9,0xab,0xfb,0x41,0xbd,0x6b, + 0x5b,0xe0,0xcd,0x19,0x13,0x7e,0x21,0x79 +} ; + +static inline int crypto_hash_sha512(unsigned char *out,const unsigned char *in,unsigned long long inlen) +{ + unsigned char h[64]; + unsigned char padded[256]; + int i; + unsigned long long bytes = inlen; + + for (i = 0;i < 64;++i) h[i] = iv[i]; + + blocks(h,in,inlen); + in += inlen; + inlen &= 127; + in -= inlen; + + for (i = 0;i < inlen;++i) padded[i] = in[i]; + padded[inlen] = 0x80; + + if (inlen < 112) { + for (i = inlen + 1;i < 119;++i) padded[i] = 0; + padded[119] = bytes >> 61; + padded[120] = bytes >> 53; + padded[121] = bytes >> 45; + padded[122] = bytes >> 37; + padded[123] = bytes >> 29; + padded[124] = bytes >> 21; + padded[125] = bytes >> 13; + padded[126] = bytes >> 5; + padded[127] = bytes << 3; + blocks(h,padded,128); + } else { + for (i = inlen + 1;i < 247;++i) padded[i] = 0; + padded[247] = bytes >> 61; + padded[248] = bytes >> 53; + padded[249] = bytes >> 45; + padded[250] = bytes >> 37; + padded[251] = bytes >> 29; + padded[252] = bytes >> 21; + padded[253] = bytes >> 13; + padded[254] = bytes >> 5; + padded[255] = bytes << 3; + blocks(h,padded,256); + } + + for (i = 0;i < 64;++i) out[i] = h[i]; + + return 0; +} diff --git a/bundled/cbits/ref10/sign.c b/bundled/cbits/ref10/sign.c new file mode 100644 index 0000000..3abd866 --- /dev/null +++ b/bundled/cbits/ref10/sign.c @@ -0,0 +1,38 @@ +#include "ed25519.h" +#include "sha512.h" +#include "ge.h" +#include "sc.h" + +int ed25519_sign( + unsigned char *sm,unsigned long long *smlen, + const unsigned char *m,unsigned long long mlen, + const unsigned char *sk +) +{ + unsigned char az[64]; + unsigned char r[64]; + unsigned char hram[64]; + ge_p3 R; + unsigned long long i; + + crypto_hash_sha512(az,sk,32); + az[0] &= 248; + az[31] &= 63; + az[31] |= 64; + + *smlen = mlen + 64; + for (i = 0;i < mlen;++i) sm[64 + i] = m[i]; + for (i = 0;i < 32;++i) sm[32 + i] = az[32 + i]; + crypto_hash_sha512(r,sm + 32,mlen + 32); + for (i = 0;i < 32;++i) sm[32 + i] = sk[32 + i]; + + sc_reduce(r); + ge_scalarmult_base(&R,r); + ge_p3_tobytes(sm,&R); + + crypto_hash_sha512(hram,sm,mlen + 64); + sc_reduce(hram); + sc_muladd(sm + 32,hram,az,r); + + return 0; +} diff --git a/bundled/cbits/ref10/test.c b/bundled/cbits/ref10/test.c new file mode 100644 index 0000000..4247d7f --- /dev/null +++ b/bundled/cbits/ref10/test.c @@ -0,0 +1,31 @@ +#include +#include +#include "ed25519.h" + +unsigned char pk[crypto_sign_PUBLICKEYBYTES]; +unsigned char sk[crypto_sign_SECRETKEYBYTES]; + +int main() +{ + int r = 0; + + ed25519_sign_keypair(pk,sk); + printf("Keypair generated.\n"); + + unsigned char *msg = "Hello"; + unsigned char sm[5+crypto_sign_BYTES]; + unsigned long long smlen; + + r = ed25519_sign(sm, &smlen, msg, 5, sk); + assert(r == 0); + printf("Signed message (length = %u)\n",smlen); + + unsigned long long mlen; + unsigned char m[5+crypto_sign_BYTES]; + + r = ed25519_sign_open(m, &mlen, sm, smlen, pk); + assert(r == 0); + printf("Verified message (length = %u)\n",mlen); + + return 0; +} diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..0b420c9 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings, Strict #-} + +module Main where + +import Control.Monad +import qualified Data.ByteString as B +import Data.ByteString.Base32 (decodeBase32, encodeBase32) +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as BC8 +import Data.Coerce +import Data.Char +import Data.List +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import qualified Data.Vector as V +import Network.ONCRPC.XDR.Serial +import Network.ONCRPC.XDR.Array +import Network.Stellar.Keypair (encodeKey, EncodingVersion(..)) +import Network.Stellar.TransactionXdr +import qualified Stellar.Simple as S +import System.Directory +import System.IO + +main = do + transactionB64 <- B.getContents + let transaction = case B64.decode $ BC8.strip transactionB64 of + Left err -> error err + Right x -> x + let parsedTransaction = case xdrDeserialize transaction :: Either String TransactionEnvelope of + Left err -> error err + Right x -> x + T.putStrLn $ pretty parsedTransaction + proceed <- confirm + when proceed $ do + key <- getPrivateKey + let sd = S.signWithSecret key parsedTransaction + T.putStrLn $ S.xdrSerializeBase64T sd + +getPrivateKey = do + home <- getHomeDirectory + keyFile <- T.readFile $ home ++ "/.stellar-veritas-key" + pure $ T.strip keyFile + +confirm :: IO Bool +confirm = do + isTerm <- hIsTerminalDevice stdout + if isTerm then do + tty <- openFile "/dev/tty" ReadWriteMode + hPutStr tty "Sign this transaction? [y/N]: " + hFlush tty + response <- hGetLine tty + hClose tty + pure $ response `elem` ["y", "Y"] + else pure True + +b32 = encodeBase32 . unLengthArray +--b64 = T.decodeLatin1 . B64.encode . unLengthArray +utf8s = T.decodeUtf8Lenient . unLengthArray +prettyKey x = encodeKey EncodingAccount $ unLengthArray x +prettyAmount amount = T.show ((fromIntegral amount) / 1e7) +prettyUnlines x = T.concat $ intersperse "\n" x +prettyAssetCode x = T.decodeUtf8Lenient $ B.takeWhile (/= 0) $ unLengthArray x + +class Pretty a where + pretty :: a -> T.Text + +instance Pretty TransactionEnvelope where + pretty (TransactionEnvelope'ENVELOPE_TYPE_TX_V0 x) = pretty x + pretty (TransactionEnvelope'ENVELOPE_TYPE_TX x) = pretty x + pretty (TransactionEnvelope'ENVELOPE_TYPE_TX_FEE_BUMP x) = T.concat ["Fee bump to ", T.show x] + +instance Pretty TransactionV0Envelope where + pretty x = pretty $ transactionV0Envelope'tx x + +instance Pretty TransactionV1Envelope where + pretty x = pretty $ transactionV1Envelope'tx x + +instance Pretty TransactionV0 where + pretty x = prettyUnlines $ map T.concat + [ ["Fee: ", T.show (transactionV0'fee x)] + , ["Sequence: ", T.show (transactionV0'seqNum x)] + ] + +instance Pretty Transaction where + pretty x = prettyUnlines $ map T.concat + [ ["Source account: ", pretty $ transaction'sourceAccount x] + , ["Memo: ", pretty $ transaction'memo x] + , ["Operations:\n", prettyUnlines $ map (\op -> T.concat [" ", pretty op]) $ V.toList $ unLengthArray $ transaction'operations x] + , ["Fee: ", T.show (transaction'fee x), " stroops"] + , ["Sequence: ", T.show (transaction'seqNum x)] + , ["Conditions: ", pretty (transaction'cond x)] + ] + +instance Pretty Memo where + pretty Memo'MEMO_NONE = "" + pretty (Memo'MEMO_ID x) = T.show x + pretty (Memo'MEMO_HASH x) = T.show x + pretty (Memo'MEMO_RETURN x) = T.show x + pretty (Memo'MEMO_TEXT t) = utf8s t + +instance Pretty Preconditions where + pretty Preconditions'PRECOND_NONE = "None" + pretty (Preconditions'PRECOND_TIME (TimeBounds min max)) = T.concat ["Time ", T.show min, " to ", T.show max] + pretty (Preconditions'PRECOND_V2 cond) = T.show cond + +instance Pretty Operation where + pretty (Operation Nothing body) = pretty body + pretty (Operation (Just account) body) = T.concat ["As ", pretty account, " ", pretty body] + +instance Pretty OperationBody where + pretty (OperationBody'CREATE_ACCOUNT x) = pretty x + pretty (OperationBody'PAYMENT x) = pretty x +-- pretty (OperationBody'PATH_PAYMENT_STRICT_RECEIVE x) = pretty x +-- pretty (OperationBody'MANAGE_SELL_OFFER x) = pretty x +-- pretty (OperationBody'CREATE_PASSIVE_SELL_OFFER x) = pretty x + pretty (OperationBody'SET_OPTIONS x) = pretty x + pretty (OperationBody'CHANGE_TRUST x) = pretty x +-- pretty (OperationBody'ALLOW_TRUST x) = pretty x +-- pretty (OperationBody'ACCOUNT_MERGE x) = pretty x + pretty OperationBody'INFLATION = "Inflation" + pretty (OperationBody'MANAGE_DATA x) = pretty x +-- pretty (OperationBody'BUMP_SEQUENCE x) = pretty x +-- pretty (OperationBody'MANAGE_BUY_OFFER x) = pretty x +-- pretty (OperationBody'PATH_PAYMENT_STRICT_SEND x) = pretty x +-- pretty (OperationBody'CREATE_CLAIMABLE_BALANCE x) = pretty x +-- pretty (OperationBody'CLAIM_CLAIMABLE_BALANCE x) = pretty x + pretty (OperationBody'BEGIN_SPONSORING_FUTURE_RESERVES (BeginSponsoringFutureReservesOp account)) = T.concat ["Sponsoring reserves for ", pretty account] + pretty OperationBody'END_SPONSORING_FUTURE_RESERVES = "No longer sponsored reserves" +-- pretty (OperationBody'REVOKE_SPONSORSHIP x) = pretty x +-- pretty (OperationBody'CLAWBACK x) = pretty x +-- pretty (OperationBody'CLAWBACK_CLAIMABLE_BALANCE x) = pretty x +-- pretty (OperationBody'SET_TRUST_LINE_FLAGS x) = pretty x +-- pretty (OperationBody'LIQUIDITY_POOL_DEPOSIT x) = pretty x +-- pretty (OperationBody'LIQUIDITY_POOL_WITHDRAW x) = pretty x + pretty x = T.show x + +instance Pretty SetOptionsOp where + pretty x = let prettyMaybe description prettifier x = pure $ T.concat [" ", description, prettifier x] in + T.concat ["Set options:\n", prettyUnlines $ catMaybes + [ setOptionsOp'inflationDest x >>= prettyMaybe "Set inflation destination to " pretty + , setOptionsOp'clearFlags x >>= prettyMaybe "Clear flags: " T.show + , setOptionsOp'setFlags x >>= prettyMaybe "Set flags: " T.show + , setOptionsOp'masterWeight x >>= prettyMaybe "Master key weight: " T.show + , setOptionsOp'lowThreshold x >>= prettyMaybe "Low signing threshold: " T.show + , setOptionsOp'medThreshold x >>= prettyMaybe "Medium signing threshold: " T.show + , setOptionsOp'highThreshold x >>= prettyMaybe "High signing threshold: " T.show + , setOptionsOp'homeDomain x >>= prettyMaybe "Home domain: " T.show + , setOptionsOp'signer x >>= prettyMaybe "Signer: " pretty + ]] + +instance Pretty Signer where + pretty (Signer key weight) = T.concat [pretty key, " (", T.show weight, ")"] + +instance Pretty SignerKey where + pretty (SignerKey'SIGNER_KEY_TYPE_ED25519 x) = prettyKey x + pretty x = T.show x + +instance Pretty CreateAccountOp where + pretty (CreateAccountOp dest bal) = T.concat ["Create account ", pretty dest, " with starting balance ", T.show bal] + +instance Pretty ChangeTrustOp where + pretty (ChangeTrustOp line limit) = T.concat ["Trust ", pretty line, " up to ", T.show limit] + +instance Pretty PaymentOp where + pretty (PaymentOp dest ass amount) = T.concat ["Pay ", prettyAmount amount, " ", pretty ass, " to ", pretty dest] + +instance Pretty ManageDataOp where + pretty (ManageDataOp name Nothing) = T.concat ["Data ", utf8s name, " cleared"] + pretty (ManageDataOp name (Just value)) = T.concat ["Data ", utf8s name, " = ", utf8s value] + +instance Pretty MuxedAccount where + pretty (MuxedAccount'KEY_TYPE_ED25519 x) = prettyKey x + pretty (MuxedAccount'KEY_TYPE_MUXED_ED25519 id key) = T.concat [b32 key, " (", T.show id, ")"] + +instance Pretty PublicKey where + pretty (PublicKey'PUBLIC_KEY_TYPE_ED25519 x) = prettyKey x + +instance Pretty Asset where + pretty Asset'ASSET_TYPE_NATIVE = "XLM" + pretty (Asset'ASSET_TYPE_CREDIT_ALPHANUM4 x) = pretty x + pretty (Asset'ASSET_TYPE_CREDIT_ALPHANUM12 x) = pretty x + +instance Pretty AlphaNum4 where + pretty (AlphaNum4 code issuer) = T.concat [prettyAssetCode code, "-", pretty issuer] +instance Pretty AlphaNum12 where + pretty (AlphaNum12 code issuer) = T.concat [prettyAssetCode code, "-", pretty issuer] diff --git a/src/stellar-veritas.cabal b/src/stellar-veritas.cabal new file mode 100644 index 0000000..e6d37d6 --- /dev/null +++ b/src/stellar-veritas.cabal @@ -0,0 +1,31 @@ +cabal-version: 3.0 +name: stellar-veritas +-- semver +version: 0 +synopsis: Stellar transaction signer and pretty-printer +-- description: +license: AGPL-3.0-only +license-file: LICENSE +-- author: +-- maintainer: +-- copyright: +category: Network, Stellar +build-type: Simple +tested-with: GHC == 9.12.3 + +executable stellar-veritas + main-is: Main.hs + ghc-options: -W -Wcompat -fno-warn-tabs -g + other-modules: + -- other-extensions: + build-depends: base >= 4.9 && < 5, + text >= 1.2.4.1 && < 2.2, + bytestring ^>= 0.12, + base32 ^>= 0.4, + base64-bytestring ^>= 1.2.1.0, + directory ^>= 1.3.9.0, + vector ^>= 0.13.2.0, + stellar-sdk ^>= 0.2, + stellar-horizon, + hs-source-dirs: . + default-language: Haskell2010 diff --git a/stellar-veritas.cabal b/stellar-veritas.cabal new file mode 100644 index 0000000..65522a4 --- /dev/null +++ b/stellar-veritas.cabal @@ -0,0 +1,49 @@ +cabal-version: 3.0 +name: stellar-veritas +-- semver +version: 0 +synopsis: Stellar transaction signer and pretty-printer +description: The aim is to create a trustworthy Stellar transaction signer (and, by necessity, a pretty printer) using only Glasgow Haskell compiler code and Haskell Core libraries, reducing the possible supply chain attack surface. +license: AGPL-3.0-only +license-file: COPYING +author: La Ancapo +category: Network, Stellar +build-type: Simple +tested-with: GHC == 9.12.3 + +executable stellar-veritas + main-is: Main.hs + ghc-options: -W -Wcompat -fno-warn-tabs -g + other-modules: + build-depends: base >= 4.9 && < 5, + text >= 1.2.4.1 && < 2.2, + bytestring ^>= 0.12, + directory ^>= 1.3.9.0, + vector ^>= 0.13.2.0, + time ^>= 1.14, + containers ^>= 0.7, + array ^>= 0.5.8.0, + binary ^>= 0.8.9.3, + deepseq ^>= 1.5.1.0, + primitive ^>= 0.9.1.0, + template-haskell ^>= 2.23.0.0, + filepath ^>= 1.5.4.0, + ghc-prim ^>= 0.13.0, + hs-source-dirs: src, bundled + default-language: Haskell2010 + other-extensions: + BangPatterns + CPP + DeriveDataTypeable + FlexibleContexts + FlexibleInstances + GADTs + KindSignatures + MagicHash + MultiParamTypeClasses + ScopedTypeVariables + Trustworthy + TypeOperators + UnliftedFFITypes + c-sources: bundled/cbits/ref10/ed25519.c + include-dirs: bundled/cbits/ref10 bundled/cbits/ref10/include