diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright 2014 Tony Morris + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,44 @@ +#!/usr/bin/env runhaskell +\begin{code} +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +import Data.List ( nub ) +import Data.Version ( showVersion ) +import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) +import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) +import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) +import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) +import Distribution.Simple.BuildPaths ( autogenModulesDir ) +import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) +import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) +import Distribution.Verbosity ( Verbosity ) +import System.FilePath ( () ) + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { buildHook = \pkg lbi hooks flags -> do + generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi + buildHook simpleUserHooks pkg lbi hooks flags + } + +generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () +generateBuildModule verbosity pkg lbi = do + let dir = autogenModulesDir lbi + createDirectoryIfMissingVerbose verbosity True dir + withLibLBI pkg lbi $ \_ libcfg -> do + withTestLBI pkg lbi $ \suite suitecfg -> do + rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines + [ "module Build_" ++ testName suite ++ " where" + , "deps :: [String]" + , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) + ] + where + formatdeps = map (formatone . snd) + formatone p = case packageName p of + PackageName n -> n ++ "-" ++ showVersion (packageVersion p) + +testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] +testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys + +\end{code} diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,4 @@ +0.0.1 + +Initial release + diff --git a/etc/ATTRIBUTIONS b/etc/ATTRIBUTIONS new file mode 100644 --- /dev/null +++ b/etc/ATTRIBUTIONS @@ -0,0 +1,36 @@ +-------------------------------------------------------------------------------- +binary +------ + +Copyright (c) Lennart Kolmodin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +-------------------------------------------------------------------------------- diff --git a/src/Data/Tickle.hs b/src/Data/Tickle.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tickle.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Tickle( + module T +) where + +import Data.Tickle.Get as T +import Data.Tickle.IsolateError as T +import Data.Tickle.RunGetResult as T diff --git a/src/Data/Tickle/Get.hs b/src/Data/Tickle/Get.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tickle/Get.hs @@ -0,0 +1,1743 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE Trustworthy #-} + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +module Data.Tickle.Get( + -- * Get data type + Get + -- ** Primitive parsers +, getLazyByteString +, getLazyByteStringNul +, getRemainingLazyByteString +, getPtr +, getWord8 +, getWord16be +, getWord16le +, getWord32be +, getWord32le +, getWord64be +, getWord64le +, getWordhost +, getWord16host +, getWord32host +, getWord64host +, failGet +, constant +, bytesRead +, demandInput +, skip +, isNotEmpty +, isEmpty +, getByteString +, modify +, readN +, ensureN + -- ** Higher-level combinators +, runAndKeepTrack +, pushBack +, pushFront +, xrunGetIncremental +, noMeansNo +, prompt +, isolate +, lookAhead +, lookAheadM +, lookAheadE +, readNWith +, calculateOffset +, pushChunk +, pushChunks +, pushEndOfInput + -- ** Error label +, (!+) +, addLabel +, (!-) +, setLabel +, (!!-) +, modifyLabel + -- * Decoder +, Decoder +, decoder +, _Fail +, _Partial +, _Done + -- ** Run Get parser +, runGet +, runGetIncremental + -- * XDecoder data type +, XDecoder + -- ** Reduction +, xdecoder + -- ** Prisms +, _XFail +, _XPartial +, _XDone +, _XBytesRead + -- * CompletedXDecoder data type +, CompletedXDecoder + -- ** Reduction +, completedXDecoder + -- ** Prism +, _CompletedFail +, _CompletedDone + -- ** Isomorphism +, completedIso + -- ** Lens +, completedByteString +, completedValue + -- ** Prism +, uncomplete + -- ** Traversal +, uncompletedByteString +, uncompletedValue +) where + +import Control.Applicative(Applicative((<*>), pure), (<$>)) +import Control.Category(Category((.), id)) +import Control.Lens.Iso(iso) +import Control.Lens.Lens(lens) +import Control.Lens.Prism(prism') +import Control.Lens.Review((#)) +import Control.Lens.Type(Iso, Prism', Lens', Traversal') +import Control.Monad(Monad((>>=), (>>), return), ap) +import Data.Bifoldable(Bifoldable(bifoldMap)) +import Data.Bifunctor(Bifunctor(bimap)) +import Data.Bitraversable(Bitraversable(bitraverse)) +import Data.Bits((.|.)) +import Data.Bool(Bool(False, True), (&&), not) +import qualified Data.ByteString as B(ByteString, concat, append, length, splitAt, empty, null, break, drop) +import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Lazy as L(ByteString, toChunks, fromChunks) +import qualified Data.ByteString.Lazy.Internal as LI(ByteString(Chunk, Empty)) +import qualified Data.ByteString.Unsafe as BU(unsafeDrop, unsafeTake, unsafeHead, unsafeIndex, unsafeUseAsCString) +import Data.Either(Either(Left, Right), either) +import Data.Eq(Eq((==))) +import Data.Foldable(Foldable(foldMap)) +import Data.Function(const) +import Data.Functor(Functor(fmap)) +import Data.Functor.Apply(Apply((<.>))) +import Data.Functor.Alt(Alt(())) +import qualified Data.Functor.Alt as Al(Alt(some, many)) +import Data.Functor.Bind(Bind((>>-))) +import Data.Int(Int, Int64) +import Data.List(reverse) +import Data.Maybe(Maybe(Nothing, Just), maybe, isJust) +import Data.Monoid(Monoid(mempty)) +import Data.Ord(Ord((>), (>=), (<), (>=))) +import Data.Semigroup(Semigroup((<>))) +import Data.Tickle.IsolateError(IsolateError, _NegativeSize, _IsolateXFail, _UnexpectedConsumed) +import Data.Tickle.RunGetResult(RunGetResult, _RunGet, _RunGetFail) +import Data.Traversable(Traversable(traverse)) +import Data.Tuple(uncurry) +import Foreign(Ptr, castPtr, Storable(peek), sizeOf) +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Word(Word, Word8, Word16(W16#), Word32(W32#), Word64(W64#)) +import GHC.Base(uncheckedShiftL#, Int(I#)) +#endif +import Prelude(Num((-), (+)), ($!), Show, fromIntegral, undefined) +import System.IO(IO) + +-- $setup +-- >>> import Control.Lens.Fold((^?)) +-- >>> import Control.Lens.Prism(_Right, _Left) +-- >>> import qualified Data.ByteString.Lazy.Char8 as BLC(pack) +-- >>> import qualified Data.ByteString.Char8 as BC(ByteString, pack) +-- >>> import Data.String(String) +-- >>> import Data.List((++)) +-- >>> import Data.Maybe(fromMaybe, isNothing) +-- >>> import Data.Validation(_Success, _Failure) +-- >>> import Prelude(Num((*)), subtract, even, mod) + +newtype Get e a = + Get (forall r. + B.ByteString -> + (B.ByteString -> a -> XDecoder e r) -> + XDecoder e r) + +bimapG :: + (e -> f) + -> (a -> b) + -> Get e a + -> Get f b +bimapG f g (Get z) = + Get (\b q -> + let r = z b XDone + go (XDone i a) = q i (g a) + go (XPartial k) = XPartial (go . k) + go (XFail i s) = XFail i (f s) + go (XBytesRead u k) = XBytesRead u (go . k) + in go r) +{-# INLINE bimapG #-} + +-- | Map on the error and result of a @Get@ decoder. +-- +-- >>> runGet (bimap (const True) (\x -> x + x) getWord8) (BLC.pack "") +-- RunGetFail 0 True +-- +-- >>> runGet (bimap (const True) (\x -> x + x) getWord8) (BLC.pack "abc") +-- RunGet 194 +instance Bifunctor Get where + bimap = + bimapG + +fmapG :: + (a -> b) + -> Get e a + -> Get e b +fmapG = + bimapG id +{-# INLINE fmapG #-} + +-- | Map on the result of a @Get@ decoder. +-- +-- >>> runGet (fmap (\x -> x + x) getWord8) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet (fmap (\x -> x + x) getWord8) (BLC.pack "abc") +-- RunGet 194 +instance Functor (Get e) where + fmap = + fmapG + +-- | Apply a function on the @Get@ decoder result. +-- +-- >>> runGet (fmap (+) getWord8 <.> getWord8) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet (fmap (+) getWord8 <.> getWord8) (BLC.pack "a") +-- RunGetFail 1 () +-- +-- >>> runGet (fmap (+) getWord8 <.> getWord8) (BLC.pack "ab") +-- RunGet 195 +-- +-- >>> runGet (fmap (+) getWord8 <.> getWord8) (BLC.pack "abc") +-- RunGet 195 +instance Apply (Get e) where + (<.>) = + ap + +apG :: + Get e (a -> b) + -> Get e a + -> Get e b +apG d e = + do b <- d + a <- e + return (b a) +{-# INLINE [0] apG #-} + +-- | Apply a function on the @Get@ decoder result. +-- +-- >>> runGet (fmap (+) getWord8 <*> getWord8) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet (fmap (+) getWord8 <*> getWord8) (BLC.pack "a") +-- RunGetFail 1 () +-- +-- >>> runGet (fmap (+) getWord8 <*> getWord8) (BLC.pack "ab") +-- RunGet 195 +-- +-- >>> runGet (fmap (+) getWord8 <*> getWord8) (BLC.pack "abc") +-- RunGet 195 +-- +-- >>> runGet (pure 7 :: Get () Int) (BLC.pack "abc") +-- RunGet 7 +-- +-- prop> runGet (pure x :: Get () Int) (BLC.pack "abc") == _RunGet # x +instance Applicative (Get e) where + pure = + return + {-# INLINE pure #-} + (<*>) = + apG + {-# INLINE (<*>) #-} + +-- | Sequence an action through the @Get@ decoder. +-- +-- >>> runGet (getWord8 >>- \c1 -> fmap (\c2 -> c1 + c2) getWord8) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet (getWord8 >>- \c1 -> fmap (\c2 -> c1 + c2) getWord8) (BLC.pack "a") +-- RunGetFail 1 () +-- +-- >>> runGet (getWord8 >>- \c1 -> fmap (\c2 -> c1 + c2) getWord8) (BLC.pack "ab") +-- RunGet 195 +-- +-- >>> runGet (getWord8 >>- \c1 -> fmap (\c2 -> c1 + c2) getWord8) (BLC.pack "abc") +-- RunGet 195 +instance Bind (Get e) where + (>>-) = + (>>=) + +returnG :: + a + -> Get e a +returnG a = + Get (\b q -> q b a) +{-# INLINE [0] returnG #-} + +bindG :: + Get e a + -> (a -> Get e b) + -> Get e b +Get k `bindG` f = + Get (\b q -> k b (\c a -> + let Get l = f a + in l c q)) +{-# INLINE bindG #-} + +-- | Sequence an action through the @Get@ decoder. +-- +-- >>> runGet (return 7 :: Get () Int) (BLC.pack "abc") +-- RunGet 7 +-- +-- prop> runGet (return x :: Get () Int) (BLC.pack "abc") == _RunGet # x +-- +-- >>> runGet (getWord8 >>= \c1 -> getWord8 >>= \c2 -> return (c1 + c2)) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet (getWord8 >>= \c1 -> getWord8 >>= \c2 -> return (c1 + c2)) (BLC.pack "a") +-- RunGetFail 1 () +-- +-- >>> runGet (getWord8 >>= \c1 -> getWord8 >>= \c2 -> return (c1 + c2)) (BLC.pack "ab") +-- RunGet 195 +-- +-- >>> runGet (getWord8 >>= \c1 -> getWord8 >>= \c2 -> return (c1 + c2)) (BLC.pack "abc") +-- RunGet 195 +instance Monad (Get e) where + return = + returnG + (>>=) = + bindG + +-- | Pick between two @Get@ decoders, finding the first to not fail. +-- +-- >>> runGet ((+1) <$> getWord8 subtract 1 <$> getWord8) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet ((+1) <$> getWord8 subtract 1 <$> getWord8) (BLC.pack "abc") +-- RunGet 98 +-- +-- >>> runGet (getWord8 failGet ()) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet (getWord8 failGet ()) (BLC.pack "abc") +-- RunGet 97 +-- +-- >>> runGet (Al.some getWord8) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet (Al.some getWord8) (BLC.pack "a") +-- RunGet [97] +-- +-- >>> runGet (Al.some getWord8) (BLC.pack "abc") +-- RunGet [97,98,99] +-- +-- >>> runGet (Al.many getWord8) (BLC.pack "") +-- RunGet [] +-- +-- >>> runGet (Al.many getWord8) (BLC.pack "a") +-- RunGet [97] +-- +-- >>> runGet (Al.many getWord8) (BLC.pack "abc") +-- RunGet [97,98,99] +instance Alt (Get e) where + f g = + do (d, bs) <- runAndKeepTrack f + case d of + CompletedDone b a -> Get (\_ q -> q b a) + CompletedFail _ _ -> pushBack bs >> g + some p = + (:) <$> p <*> Al.many p + many p = + (p >>= \x -> + fmap (x:) (Al.many p)) pure [] + +-- | Pick between two @Get@ decoders, finding the first to not fail. +-- +-- >>> runGet (((+1) <$> getWord8) <> (subtract 1 <$> getWord8)) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet (((+1) <$> getWord8) <> (subtract 1 <$> getWord8)) (BLC.pack "abc") +-- RunGet 98 +-- +-- >>> runGet (getWord8 <> failGet ()) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet (getWord8 <> failGet ()) (BLC.pack "abc") +-- RunGet 97 +instance Semigroup (Get e a) where + (<>) = + () + +-- | A @Get@ decoder that always fails with the given value. +-- +-- prop> runGet (failGet x :: Get Int ()) (BLC.pack s) == _RunGetFail # (0, x) +-- +-- >>> runGet (failGet "abc" :: Get String ()) (BLC.pack "def") +-- RunGetFail 0 "abc" +failGet :: + e + -> Get e a +failGet e = + Get (\i _ -> XFail i e) + +constant :: + (forall r. XDecoder e r) + -> Get e a +constant d = + Get (\_ _ -> d) + +-- | Run a @Get@ decoder, but keep a track of the input that ran it to completion. +-- +-- >>> runGet (runAndKeepTrack getWord8 :: Get () (CompletedXDecoder () Word8, [BC.ByteString])) (BLC.pack "") +-- RunGet (CompletedFail "" (),[]) +-- +-- >>> runGet (runAndKeepTrack getWord8 :: Get () (CompletedXDecoder () Word8, [BC.ByteString])) (BLC.pack "abc") +-- RunGet (CompletedDone "bc" 97,["abc"]) +runAndKeepTrack :: + Get e a + -> Get x (CompletedXDecoder e a, [B.ByteString]) +runAndKeepTrack (Get k) = + Get (\b q -> + let go !acc w = case w of + XDone c a -> q b (CompletedDone c a, reverse acc) + XPartial l -> XPartial (\c -> go (maybe acc (:acc) c) (l c)) + XFail c e -> q b (CompletedFail c e, reverse acc) + XBytesRead i l -> XBytesRead i (go acc . l) + in go [] (k b XDone)) +{-# INLINE runAndKeepTrack #-} + +-- | +-- +-- >>> runGet (pushBack [] :: Get () ()) (BLC.pack "") +-- RunGet () +-- +-- >>> runGet (pushBack [] :: Get () ()) (BLC.pack "abc") +-- RunGet () +-- +-- >>> runGet (pushBack [BC.pack "def"] :: Get () ()) (BLC.pack "") +-- RunGet () +-- +-- >>> runGet (pushBack [BC.pack "def"] :: Get () ()) (BLC.pack "abc") +-- RunGet () +pushBack :: + [B.ByteString] + -> Get e () +pushBack z = + let y [] = id + y _ = B.concat . (:z) + in Get (\b q -> q (y z b) ()) +{-# INLINE pushBack #-} + +-- | +-- +-- >>> runGet (pushFront (BC.pack "def") :: Get () ()) (BLC.pack "") +-- RunGet () +-- +-- >>> runGet (pushFront (BC.pack "def") :: Get () ()) (BLC.pack "abc") +-- RunGet () +pushFront :: + B.ByteString + -> Get e () +pushFront b = + Get (\c q -> q (B.append b c) ()) +{-# INLINE pushFront #-} + +xrunGetIncremental :: + Get e a + -> XDecoder e a +xrunGetIncremental (Get k) = + noMeansNo (k B.empty XDone) + +noMeansNo :: + XDecoder e a + -> XDecoder e a +noMeansNo = + let neverAgain (XPartial k) = + neverAgain (k Nothing) + neverAgain (XBytesRead i k) = + XBytesRead i (neverAgain . k) + neverAgain r@(XDone _ _) = + r + neverAgain r@(XFail _ _) = + r + go (XPartial k) = + XPartial (\b -> + (if isJust b then go else neverAgain) (k b)) + go (XBytesRead i k) = + XBytesRead i (go . k) + go r@(XDone _ _) = + r + go r@(XFail _ _) = + r + in go + +prompt :: + B.ByteString + -> XDecoder e a + -> (B.ByteString -> XDecoder e a) + -> XDecoder e a +prompt b d f = + let loop = XPartial (maybe d (\s -> if B.null s then loop else f (b `B.append` s))) + in loop + +-- | +-- +-- >>> runGet (bytesRead :: Get () Int64) (BLC.pack "") +-- RunGet 0 +-- +-- >>> runGet (bytesRead :: Get () Int64) (BLC.pack "abc") +-- RunGet 0 +-- +-- >>> runGet (getWord8 >> getWord16be >> getWord32le >> bytesRead) (BLC.pack "abcdefghijk") +-- RunGet 7 +bytesRead :: + Get e Int64 +bytesRead = + Get (\b q -> XBytesRead (fromIntegral (B.length b)) (q b)) + +-- | +-- +-- >>> runGet (isolate 1 getWord8) (BLC.pack "ab") +-- RunGet 97 +-- +-- >>> runGet (isolate 1 getWord8) (BLC.pack "abcde") +-- RunGet 97 +-- +-- >>> runGet (isolate 2 getWord16le) (BLC.pack "abcde") +-- RunGet 25185 +-- +-- >>> runGet (isolate 1 getWord16le) (BLC.pack "abcde") +-- RunGetFail 0 (IsolateXFail ()) +-- +-- >>> runGet (isolate (-3) getWord16le) (BLC.pack "abcde") +-- RunGetFail 0 NegativeSize +-- +-- >>> runGet (isolate 3 getWord16le) (BLC.pack "abcde") +-- RunGetFail 2 (UnexpectedConsumed 2 3) +isolate :: + Int + -> Get e a + -> Get (IsolateError e) a +isolate m (Get k) = + let go !n (XDone l x) = + if n == 0 && B.null l + then + return x + else + do pushFront l + failGet (_UnexpectedConsumed # (m - n - B.length l, m)) + go 0 (XPartial r) = + go 0 (r Nothing) + go n (XPartial r) = + do i <- Get (\b q -> let takeLimited t = + let (j, o) = B.splitAt n t + in q o (Just j) + in if B.null b + then + prompt b (q B.empty Nothing) takeLimited + else + takeLimited b) + case i of + Nothing -> + go n (r Nothing) + Just u -> + go (n - B.length u) (r (Just u)) + go _ (XFail b e) = + pushFront b >> failGet (_IsolateXFail # e) + go n (XBytesRead i r) = + go n (r $! fromIntegral m - fromIntegral n - i) + in if m < 0 + then + failGet (_NegativeSize # ()) + else + go m (k B.empty XDone) + +-- | +-- +-- >>> runGet demandInput (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet demandInput (BLC.pack "a") +-- RunGet () +-- +-- >>> runGet demandInput (BLC.pack "abc") +-- RunGet () +demandInput :: + Get () () +demandInput = + Get (\b q -> + prompt b (XFail b ()) (`q` ())) + +-- | +-- +-- >>> runGet (getWord8 >>= \c -> skip 2 >> getWord8 >>= \d -> return (c,d)) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet (getWord8 >>= \c -> skip 2 >> getWord8 >>= \d -> return (c,d)) (BLC.pack "abcdefghi") +-- RunGet (97,100) +-- +-- >>> runGet (getWord8 >>= \c -> skip 2 >> getWord8 >>= \d -> return (c,d)) (BLC.pack "abc") +-- RunGetFail 3 () +skip :: + Int + -> Get () () +skip n = + readN n (return ()) +{-# INLINE skip #-} + +-- | +-- +-- >>> runGet isNotEmpty (BLC.pack "") +-- RunGet False +-- +-- >>> runGet isNotEmpty (BLC.pack "abc") +-- RunGet True +-- +-- >>> runGet (isNotEmpty >>= \p -> getWord8 >>= \w -> return (w, p)) (BLC.pack "abc") +-- RunGet (97,True) +-- +-- >>> runGet (isNotEmpty >>= \p -> getWord8 >>= \w -> return (w, p)) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet (isNotEmpty >>= \p -> getWord8 >>= \w -> return (w, p)) (BLC.pack "a") +-- RunGet (97,True) +isNotEmpty :: + Get e Bool +isNotEmpty = + fmap not isEmpty + +-- | +-- +-- >>> runGet isEmpty (BLC.pack "") +-- RunGet True +-- +-- >>> runGet isEmpty (BLC.pack "abc") +-- RunGet False +-- +-- >>> runGet (isEmpty >>= \p -> getWord8 >>= \w -> return (w, p)) (BLC.pack "abc") +-- RunGet (97,False) +-- +-- >>> runGet (isEmpty >>= \p -> getWord8 >>= \w -> return (w, p)) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet (isEmpty >>= \p -> getWord8 >>= \w -> return (w, p)) (BLC.pack "a") +-- RunGet (97,False) +isEmpty :: + Get e Bool +isEmpty = + Get (\b q -> + if B.null b + then + prompt b (q b True) (`q` False) + else + q b False) + +-- | +-- +-- >>> runGet (lookAhead getWord8) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet (lookAhead getWord8) (BLC.pack "abc") +-- RunGet 97 +-- +-- >>> runGet (lookAhead getWord8) (BLC.pack "a") +-- RunGet 97 +lookAhead :: + Get e a + -> Get e a +lookAhead g = + do (d, bs) <- runAndKeepTrack g + case d of + CompletedDone _ a -> + pushBack bs >> return a + CompletedFail inp s -> + constant (XFail inp s) + +-- | +-- +-- >>> runGet (lookAheadM (getWord8 >>= \w -> return (if even w then Just (w + 5) else Nothing))) (BLC.pack "abc") +-- RunGet Nothing +-- +-- >>> runGet (lookAheadM (getWord8 >>= \w -> return (if even w then Just (w + 5) else Nothing))) (BLC.pack "bc") +-- RunGet (Just 103) +-- +-- >>> runGet (lookAheadM (getWord8 >>= \w -> return (if even w then Just (w + 5) else Nothing))) (BLC.pack "") +-- RunGetFail 0 () +lookAheadM :: + Get e (Maybe a) + -> Get e (Maybe a) +lookAheadM g = + let g' = fmap (maybe (Left ()) Right) g + in fmap (either (return Nothing) Just) (lookAheadE g') + +-- | +-- +-- >>> runGet (lookAheadE (getWord8 >>= \w -> return (if even w then Left (w + 5) else Right (w - 4)))) (BLC.pack "abc") +-- RunGet (Right 93) +-- +-- >>> runGet (lookAheadE (getWord8 >>= \w -> return (if even w then Left (w + 5) else Right (w - 4)))) (BLC.pack "bc") +-- RunGet (Left 103) +-- +-- >>> runGet (lookAheadE (getWord8 >>= \w -> return (if even w then Left (w + 5) else Right (w - 4)))) (BLC.pack "") +-- RunGetFail 0 () +lookAheadE :: + Get e (Either a b) + -> Get e (Either a b) +lookAheadE g = + do (d, b) <- runAndKeepTrack g + case d of + CompletedDone _ (Left x) -> + pushBack b >> return (Left x) + CompletedDone i (Right x) -> + Get (\_ q -> q i (Right x)) + CompletedFail i s -> + constant (XFail i s) + +-- | +-- +-- >>> runGet ([(), ()] !+ (setLabel [] getWord8)) (BLC.pack "") +-- RunGetFail 0 [(),()] +-- +-- >>> runGet ([(), ()] !+ (setLabel [] getWord8)) (BLC.pack "abc") +-- RunGet 97 +(!+) :: + Semigroup e => + e + -> Get e a + -> Get e a +(!+) = + addLabel + +infixl 3 !+ + +-- | +-- +-- >>> runGet ([(), ()] `addLabel` (setLabel [] getWord8)) (BLC.pack "") +-- RunGetFail 0 [(),()] +-- +-- >>> runGet ([(), ()] `addLabel` (setLabel [] getWord8)) (BLC.pack "abc") +-- RunGet 97 +addLabel :: + Semigroup e => + e + -> Get e a + -> Get e a +addLabel m = + modifyLabel (<> m) + +-- | +-- +-- >>> runGet ("error" !- getWord8) (BLC.pack "") +-- RunGetFail 0 "error" +-- +-- >>> runGet ("error" !- getWord8) (BLC.pack "abc") +-- RunGet 97 +(!-) :: + e + -> Get d a + -> Get e a +(!-) = + setLabel + +infixl 3 !- + +-- | +-- +-- >>> runGet ("error" `setLabel` getWord8) (BLC.pack "") +-- RunGetFail 0 "error" +-- +-- >>> runGet ("error" `setLabel` getWord8) (BLC.pack "abc") +-- RunGet 97 +setLabel :: + e + -> Get d a + -> Get e a +setLabel = + modifyLabel . return + +-- | +-- +-- >>> runGet (reverse !!- setLabel "error" getWord8) (BLC.pack "") +-- RunGetFail 0 "rorre" +-- +-- >>> runGet (reverse !!- setLabel "error" getWord8) (BLC.pack "abc") +-- RunGet 97 +(!!-) :: + (d -> e) + -> Get d a + -> Get e a +(!!-) = + modifyLabel + +infixl 3 !!- + +-- | +-- +-- >>> runGet (reverse `modifyLabel` setLabel "error" getWord8) (BLC.pack "") +-- RunGetFail 0 "rorre" +-- +-- >>> runGet (reverse `modifyLabel` setLabel "error" getWord8) (BLC.pack "abc") +-- RunGet 97 +modifyLabel :: + (d -> e) + -> Get d a + -> Get e a +modifyLabel m = + bimap m id + +-- | +-- +-- >>> runGet (getByteString (-3)) (BLC.pack "") +-- RunGet "" +-- +-- >>> runGet (getByteString 3) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet (getByteString 3) (BLC.pack "abc") +-- RunGet "abc" +-- +-- >>> runGet (getByteString 3) (BLC.pack "abcdef") +-- RunGet "abc" +getByteString :: + Int + -> Get () B.ByteString +getByteString n = + if n > 0 + then + readN n (BU.unsafeTake n) + else + return B.empty +{-# INLINE getByteString #-} + +modify :: + (B.ByteString -> B.ByteString) + -> Get e () +modify f = + Get (\b q -> q (f b) ()) + +get :: + Get e B.ByteString +get = + Get (\b q -> q b b) + +put :: + B.ByteString -> Get e () +put s = + Get (\_ q -> q s ()) + +-- | +-- +-- >>> runGet (readN 3 id) (BLC.pack "abc") +-- RunGet "abc" +-- +-- >>> runGet (readN 3 id) (BLC.pack "ab") +-- RunGetFail 0 () +-- +-- >>> runGet (readN 3 id) (BLC.pack "abcdef") +-- RunGet "abcdef" +-- +-- >>> runGet (readN (-3) id) (BLC.pack "abcdef") +-- RunGet "" +readN :: + Int + -> (B.ByteString -> a) + -> Get () a +readN !n f = + ensureN n >> unsafeReadN n f +{-# INLINE [0] readN #-} + +{-# RULES + +"readN/readN merge" forall n m f g. + readN n f `apG` readN m g = + readN (n+m) (\bs -> f bs (g (BU.unsafeDrop n bs))) + +"returnG/readN swap" [~1] forall f. + returnG f = + readN 0 (const f) + +"readN 0/returnG swapback" [1] forall f. + readN 0 f = + returnG (f B.empty) + + #-} + +-- | +-- +-- >>> runGet (ensureN 3) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet (ensureN 3) (BLC.pack "abc") +-- RunGet () +-- +-- >>> runGet (ensureN 3) (BLC.pack "abcdef") +-- RunGet () +ensureN :: + Int + -> Get () () +ensureN !m = + Get (\i k -> + let go n = + Get (\b q -> if B.length b >= n + then + q b () + else + let Get g = demandInput >> go n + in g b q) + in if B.length i >= m + then + k i () + else + let Get g = go m + in g i k) +{-# INLINE ensureN #-} + +unsafeReadN :: + Int + -> (B.ByteString -> a) + -> Get e a +unsafeReadN !n f = + Get (\b ks -> ks (BU.unsafeDrop n b) $! f b) + +readNWith :: + Int + -> (Ptr a -> IO a) + -> Get () a +readNWith n f = + readN n (\s -> BI.inlinePerformIO (BU.unsafeUseAsCString s (f . castPtr))) +{-# INLINE readNWith #-} + +data Decoder e a = + Fail !B.ByteString {-# UNPACK #-} !Int64 e + | Partial (Maybe B.ByteString -> Decoder e a) + | Done !B.ByteString {-# UNPACK #-} !Int64 a + +-- | +-- +-- >>> decoder (\b i n -> B.length b + fromIntegral i + n) (\_ -> 99) (\b n a -> B.length b + fromIntegral n + a) (_Fail # (BC.pack "abc", 12, 19)) +-- 34 +-- +-- >>> decoder (\b i n -> B.length b + fromIntegral i + n) (\_ -> 99) (\b n a -> B.length b + fromIntegral n + a) (_Partial # (\b -> _Fail # (fromMaybe (BC.pack "abc") b, 12, 19))) +-- 99 +-- +-- >>> decoder (\b i n -> B.length b + fromIntegral i + n) (\_ -> 99) (\b n a -> B.length b + fromIntegral n + a) (_Done # (BC.pack "abc", 12, 19)) +-- 34 +decoder :: + (B.ByteString -> Int64 -> e -> x) + -> ((Maybe B.ByteString -> Decoder e a) -> x) + -> (B.ByteString -> Int64 -> a -> x) + -> Decoder e a + -> x +decoder f _ _ (Fail b i e) = + f b i e +decoder _ p _ (Partial k) = + p k +decoder _ _ d (Done b i a) = + d b i a + +-- | +-- +-- >>> (_Fail # (BC.pack "abc", 19, 31)) ^? _Fail +-- Just ("abc",19,31) +-- +-- >>> isNothing ((_Fail # (BC.pack "abc", 19, 31)) ^? _Partial) +-- True +-- +-- >>> (_Fail # (BC.pack "abc", 19, 31)) ^? _Done +-- Nothing +_Fail :: + Prism' (Decoder e a) (B.ByteString, Int64, e) +_Fail = + prism' + (\(b, i, e) -> Fail b i e) + (\x -> case x of + Fail b i e -> Just (b, i, e) + _ -> Nothing) + +-- | +-- +-- >>> (_Partial # (\b -> _Fail # (fromMaybe (BC.pack "abc") b, 12, 19))) ^? _Fail +-- Nothing +-- +-- >>> isJust ((_Partial # (\b -> _Fail # (fromMaybe (BC.pack "abc") b, 12, 19))) ^? _Partial) +-- True +-- +-- >>> (_Partial # (\b -> _Fail # (fromMaybe (BC.pack "abc") b, 12, 19))) ^? _Done +-- Nothing +_Partial :: + Prism' (Decoder e a) (Maybe B.ByteString -> Decoder e a) +_Partial = + prism' + Partial + (\x -> case x of + Partial k -> Just k + _ -> Nothing) + +-- | +-- +-- >>> (_Done # (BC.pack "abc", 19, 31)) ^? _Fail +-- Nothing +-- +-- >>> isNothing ((_Done # (BC.pack "abc", 19, 31)) ^? _Partial) +-- True +-- +-- >>> (_Done # (BC.pack "abc", 19, 31)) ^? _Done +-- Just ("abc",19,31) +_Done :: + Prism' (Decoder e a) (B.ByteString, Int64, a) +_Done = + prism' + (\(b, i, a) -> Done b i a) + (\x -> case x of + Done b i a -> Just (b, i, a) + _ -> Nothing) + +bimapD :: + (e -> f) + -> (a -> b) + -> Decoder e a + -> Decoder f b +bimapD f _ (Fail b i e) = + Fail b i (f e) +bimapD f g (Partial k) = + Partial (bimapD f g . k) +bimapD _ g (Done b i a) = + Done b i (g a) +{-# INLINE bimapD #-} + +-- | +-- +-- >>> (bimap (+10) (*20) (_Fail # (BC.pack "abc", 19, 31))) ^? _Fail +-- Just ("abc",19,41) +-- +-- >>> (bimap (+10) (*20) (_Done # (BC.pack "abc", 19, 31))) ^? _Done +-- Just ("abc",19,620) +instance Bifunctor Decoder where + bimap = + bimapD + +fmapD :: + (a -> b) + -> Decoder e a + -> Decoder e b +fmapD = + bimapD id +{-# INLINE fmapD #-} + +-- | +-- +-- >>> (fmap (+10) (_Fail # (BC.pack "abc", 19, 31))) ^? _Fail +-- Just ("abc",19,31) +-- +-- >>> (fmap (+10) (_Done # (BC.pack "abc", 19, 31))) ^? _Done +-- Just ("abc",19,41) +instance Functor (Decoder e) where + fmap = + fmapD + +calculateOffset :: + XDecoder e a + -> Decoder e a +calculateOffset s = + let go r !acc = + case r of + XDone i a -> + Done i (acc - fromIntegral (B.length i)) a + XFail i e -> + Fail i (acc - fromIntegral (B.length i)) e + XPartial k -> + Partial (\b -> + case b of + Nothing -> go (k Nothing) acc + Just j -> go (k b) (acc + fromIntegral (B.length j))) + XBytesRead i k -> + go (k $! (acc - i)) acc + in go s 0 + +runGetIncremental :: + Get e a + -> Decoder e a +runGetIncremental = + calculateOffset . xrunGetIncremental + +takeHeadChunk :: + L.ByteString + -> Maybe B.ByteString +takeHeadChunk lbs = + case lbs of + (LI.Chunk bs _) -> + Just bs + _ -> + Nothing + +dropHeadChunk :: + L.ByteString + -> L.ByteString +dropHeadChunk lbs = + case lbs of + (LI.Chunk _ lbs') -> + lbs' + _ -> + LI.Empty + +runGet :: + Get e a + -> L.ByteString + -> RunGetResult e a +runGet g b = + let feedAll (Done _ _ x) _ = + _RunGet # x + feedAll (Partial k) c = + feedAll (k (takeHeadChunk c)) (dropHeadChunk c) + feedAll (Fail _ p e) _ = + _RunGetFail # (p, e) + in feedAll (runGetIncremental g) b + +pushChunk :: + Decoder e a + -> B.ByteString + -> Decoder e a +pushChunk r i = + case r of + Done j p a -> + Done (j `B.append` i) p a + Partial k -> + k (Just i) + Fail j p s -> + Fail (j `B.append` i) p s + +pushChunks :: + Decoder e a + -> L.ByteString + -> Decoder e a +pushChunks r0 = + let go r [] = + r + go (Done i p a) xs = + Done (B.concat (i:xs)) p a + go (Fail i p s) xs = + Fail (B.concat (i:xs)) p s + go (Partial k) (x:xs) = + go (k (Just x)) xs + in go r0 . L.toChunks + +pushEndOfInput :: + Decoder e a + -> Decoder e a +pushEndOfInput r = + case r of + Done {} -> r + Partial k -> k Nothing + Fail {} -> r + +-- | +-- +-- >>> runGet (getLazyByteString 5) (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet (getLazyByteString 5) (BLC.pack "abc") +-- RunGetFail 3 () +-- +-- >>> runGet (getLazyByteString 5) (BLC.pack "abcdefg") +-- RunGet "abcde" +getLazyByteString :: + Int64 + -> Get () L.ByteString +getLazyByteString = + let consume n s = + if fromIntegral (B.length s) >= n + then + Right (B.splitAt (fromIntegral n) s) + else + Left (fromIntegral (B.length s)) + go n = + do s <- get + case consume n s of + Left u -> + do put B.empty + demandInput + fmap (s:) (go (n - u)) + Right (w, r) -> + do put r + return [w] + in fmap L.fromChunks . go + +-- | +-- +-- >>> runGet getLazyByteStringNul (BLC.pack "") +-- RunGetFail 0 () +-- +-- >>> runGet getLazyByteStringNul (BLC.pack "abc") +-- RunGetFail 3 () +-- +-- >>> runGet getLazyByteStringNul (BLC.pack "abc\0") +-- RunGet "abc" +-- +-- >>> runGet getLazyByteStringNul (BLC.pack "abc\0def") +-- RunGet "abc" +getLazyByteStringNul :: + Get () L.ByteString +getLazyByteStringNul = + let findNull s = + case B.break (==0) s of + (w, r) -> + if B.null r + then + Nothing + else + Just (w, B.drop 1 r) + go = + do s <- get + case findNull s of + Nothing -> + do put B.empty + demandInput + fmap (s:) go + Just (w, r) -> + do put r + return [w] + in fmap L.fromChunks go + +-- | +-- +-- >>> runGet getRemainingLazyByteString (BLC.pack "") +-- RunGet "" +-- +-- >>> runGet getRemainingLazyByteString (BLC.pack "abc") +-- RunGet "abc" +getRemainingLazyByteString :: + Get e L.ByteString +getRemainingLazyByteString = + let go = + do s <- get + put B.empty + d <- isEmpty + if d + then + return [s] + else + fmap (s:) go + in fmap L.fromChunks go + +getPtr :: + Storable a => + Int + -> Get () a +getPtr n = + readNWith n peek +{-# INLINE getPtr #-} + +{-# RULES + +"getWord8/readN" getWord8 = + readN 1 BU.unsafeHead + +"getWord16be/readN" getWord16be = + readN 2 word16be + +"getWord16le/readN" getWord16le = + readN 2 word16le + +"getWord32be/readN" getWord32be = + readN 4 word32be + +"getWord32le/readN" getWord32le = + readN 4 word32le + +"getWord64be/readN" getWord64be = + readN 8 word64be + +"getWord64le/readN" getWord64le = + readN 8 word64le + + #-} + +-- | +-- +-- >>> runGet getWord8 (BLC.pack "abc") +-- RunGet 97 +-- +-- >>> runGet getWord8 (BLC.pack "123") +-- RunGet 49 +getWord8 :: + Get () Word8 +getWord8 = + readN 1 BU.unsafeHead +{-# INLINE [0] getWord8 #-} + +word16be :: + B.ByteString + -> Word16 +word16be s = + (fromIntegral (s `BU.unsafeIndex` 0) `shiftlW16` 8) .|. + fromIntegral (s `BU.unsafeIndex` 1) +{-# INLINE word16be #-} + +-- | +-- +-- >>> runGet getWord16be (BLC.pack "abc") +-- RunGet 24930 +-- +-- >>> runGet getWord16be (BLC.pack "123") +-- RunGet 12594 +getWord16be :: + Get () Word16 +getWord16be = + readN 2 word16be +{-# INLINE [0] getWord16be #-} + +word16le :: + B.ByteString + -> Word16 +word16le s = + (fromIntegral (s `BU.unsafeIndex` 1) `shiftlW16` 8) .|. + fromIntegral (s `BU.unsafeIndex` 0) +{-# INLINE word16le #-} + +-- | +-- +-- >>> runGet getWord16le (BLC.pack "abc") +-- RunGet 25185 +-- +-- >>> runGet getWord16le (BLC.pack "123") +-- RunGet 12849 +getWord16le :: + Get () Word16 +getWord16le = + readN 2 word16le +{-# INLINE [0] getWord16le #-} + +word32be :: + B.ByteString + -> Word32 +word32be s = + (fromIntegral (s `BU.unsafeIndex` 0) `shiftlW32` 24) .|. + (fromIntegral (s `BU.unsafeIndex` 1) `shiftlW32` 16) .|. + (fromIntegral (s `BU.unsafeIndex` 2) `shiftlW32` 8) .|. + fromIntegral (s `BU.unsafeIndex` 3) +{-# INLINE word32be #-} + +-- | +-- +-- >>> runGet getWord32be (BLC.pack "abcdef") +-- RunGet 1633837924 +-- +-- >>> runGet getWord32be (BLC.pack "123456") +-- RunGet 825373492 +getWord32be :: + Get () Word32 +getWord32be = + readN 4 word32be +{-# INLINE [0] getWord32be #-} + +word32le :: + B.ByteString + -> Word32 +word32le s = + (fromIntegral (s `BU.unsafeIndex` 3) `shiftlW32` 24) .|. + (fromIntegral (s `BU.unsafeIndex` 2) `shiftlW32` 16) .|. + (fromIntegral (s `BU.unsafeIndex` 1) `shiftlW32` 8) .|. + fromIntegral (s `BU.unsafeIndex` 0) +{-# INLINE word32le #-} + +-- | +-- +-- -- >>> runGet getWord32le (BLC.pack "abcdef") +-- RunGet 1684234849 +-- +-- >>> runGet getWord32le (BLC.pack "123456") +-- RunGet 875770417 +getWord32le :: + Get () Word32 +getWord32le = + readN 4 word32le +{-# INLINE [0] getWord32le #-} + +word64be :: + B.ByteString + -> Word64 +word64be s = + (fromIntegral (s `BU.unsafeIndex` 0) `shiftlW64` 56) .|. + (fromIntegral (s `BU.unsafeIndex` 1) `shiftlW64` 48) .|. + (fromIntegral (s `BU.unsafeIndex` 2) `shiftlW64` 40) .|. + (fromIntegral (s `BU.unsafeIndex` 3) `shiftlW64` 32) .|. + (fromIntegral (s `BU.unsafeIndex` 4) `shiftlW64` 24) .|. + (fromIntegral (s `BU.unsafeIndex` 5) `shiftlW64` 16) .|. + (fromIntegral (s `BU.unsafeIndex` 6) `shiftlW64` 8) .|. + fromIntegral (s `BU.unsafeIndex` 7) +{-# INLINE word64be #-} + +-- | +-- +-- >>> runGet getWord64be (BLC.pack "abcdefghi") +-- RunGet 7017280452245743464 +-- +-- >>> runGet getWord64be (BLC.pack "123456789") +-- RunGet 3544952156018063160 +getWord64be :: + Get () Word64 +getWord64be = + readN 8 word64be +{-# INLINE [0] getWord64be #-} + +word64le :: + B.ByteString + -> Word64 +word64le s = + (fromIntegral (s `BU.unsafeIndex` 7) `shiftlW64` 56) .|. + (fromIntegral (s `BU.unsafeIndex` 6) `shiftlW64` 48) .|. + (fromIntegral (s `BU.unsafeIndex` 5) `shiftlW64` 40) .|. + (fromIntegral (s `BU.unsafeIndex` 4) `shiftlW64` 32) .|. + (fromIntegral (s `BU.unsafeIndex` 3) `shiftlW64` 24) .|. + (fromIntegral (s `BU.unsafeIndex` 2) `shiftlW64` 16) .|. + (fromIntegral (s `BU.unsafeIndex` 1) `shiftlW64` 8) .|. + fromIntegral (s `BU.unsafeIndex` 0) +{-# INLINE word64le #-} + +-- | +-- +-- >>> runGet getWord64le (BLC.pack "abcdefghi") +-- RunGet 7523094288207667809 +-- +-- >>> runGet getWord64le (BLC.pack "123456789") +-- RunGet 4050765991979987505 +getWord64le :: + Get () Word64 +getWord64le = + readN 8 word64le +{-# INLINE [0] getWord64le #-} + +-- | +-- +-- >>> runGet getWordhost (BLC.pack "abcdefghi") +-- RunGet 7523094288207667809 +-- +-- >>> runGet getWordhost (BLC.pack "123456789") +-- RunGet 4050765991979987505 +getWordhost :: + Get () Word +getWordhost = + getPtr (sizeOf (undefined :: Word)) +{-# INLINE getWordhost #-} + +-- | +-- +-- >>> runGet getWord16host (BLC.pack "abcde") +-- RunGet 25185 +-- +-- >>> runGet getWord16host (BLC.pack "12345") +-- RunGet 12849 +getWord16host :: + Get () Word16 +getWord16host = + getPtr (sizeOf (undefined :: Word16)) +{-# INLINE getWord16host #-} + +-- | +-- +-- >>> runGet getWord32host (BLC.pack "abcde") +-- RunGet 1684234849 +-- +-- >>> runGet getWord32host (BLC.pack "12345") +-- RunGet 875770417 +getWord32host :: + Get () Word32 +getWord32host = + getPtr (sizeOf (undefined :: Word32)) +{-# INLINE getWord32host #-} + +-- | +-- +-- >>> runGet getWord64host (BLC.pack "abcdeghi") +-- RunGet 7595434456733934177 +-- +-- >>> runGet getWord64host (BLC.pack "123456789") +-- RunGet 4050765991979987505 +getWord64host :: + Get () Word64 +getWord64host = + getPtr (sizeOf (undefined :: Word64)) +{-# INLINE getWord64host #-} + +------------------------------------------------------------------------ +-- Unchecked shifts + +shiftlW16 :: + Word16 + -> Int + -> Word16 +shiftlW32 :: + Word32 + -> Int + -> Word32 +shiftlW64 :: + Word64 + -> Int + -> Word64 + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftlW16 (W16# w) (I# i) = + W16# (w `uncheckedShiftL#` i) +shiftlW32 (W32# w) (I# i) = + W32# (w `uncheckedShiftL#` i) + +#if WORD_SIZE_IN_BITS < 64 +shiftlW64 (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 +shiftlW64 (W64# w) (I# i) = + W64# (w `uncheckedShiftL#` i) +#endif + +#else +shiftlW16 = + shiftL +shiftlW32 = + shiftL +shiftlW64 = + shiftL +#endif + +---- + +data XDecoder e a = + XFail !B.ByteString e + | XPartial (Maybe B.ByteString -> XDecoder e a) + | XDone !B.ByteString a + | XBytesRead {-# UNPACK #-} !Int64 (Int64 -> XDecoder e a) + +xdecoder :: + (B.ByteString -> e -> x) + -> ((Maybe B.ByteString -> XDecoder e a) -> x) + -> (B.ByteString -> a -> x) + -> (Int64 -> (Int64 -> XDecoder e a) -> x) + -> XDecoder e a + -> x +xdecoder f _ _ _ (XFail b e) = + f b e +xdecoder _ p _ _ (XPartial k) = + p k +xdecoder _ _ d _ (XDone b a) = + d b a +xdecoder _ _ _ r (XBytesRead i k) = + r i k + +_XFail :: + Prism' (XDecoder e a) (B.ByteString, e) +_XFail = + prism' + (uncurry XFail) + (\x -> case x of + XFail b e -> Just (b, e) + _ -> Nothing) + +_XPartial :: + Prism' (XDecoder e a) (Maybe B.ByteString -> XDecoder e a) +_XPartial = + prism' + XPartial + (\x -> case x of + XPartial k -> Just k + _ -> Nothing) + +_XDone :: + Prism' (XDecoder e a) (B.ByteString, a) +_XDone = + prism' + (uncurry XDone) + (\x -> case x of + XDone b a -> Just (b, a) + _ -> Nothing) +_XBytesRead :: + Prism' (XDecoder e a) (Int64, Int64 -> XDecoder e a) +_XBytesRead = + prism' + (uncurry XBytesRead) + (\x -> case x of + XBytesRead i k -> Just (i, k) + _ -> Nothing) + +{-# INLINE _XFail #-} +{-# INLINE _XPartial #-} +{-# INLINE _XDone #-} +{-# INLINE _XBytesRead #-} + +instance Functor (XDecoder e) where + fmap = + bimap id + +instance Bifunctor XDecoder where + bimap f _ (XFail b e) = + XFail b (f e) + bimap f g (XPartial k) = + XPartial (bimap f g . k) + bimap _ g (XDone b a) = + XDone b (g a) + bimap f g (XBytesRead i k) = + XBytesRead i (bimap f g . k) + +instance Bifoldable XDecoder where + bifoldMap f _ (XFail _ e) = + f e + bifoldMap _ _ (XPartial _) = + mempty + bifoldMap _ g (XDone _ a) = + g a + bifoldMap _ _ (XBytesRead _ _) = + mempty + +instance Foldable (XDecoder e) where + foldMap _ (XFail _ _) = + mempty + foldMap _ (XPartial _) = + mempty + foldMap f (XDone _ a) = + f a + foldMap _ (XBytesRead _ _) = + mempty + +data CompletedXDecoder e a = + CompletedFail !B.ByteString e + | CompletedDone !B.ByteString a + deriving (Eq, Ord, Show) + +completedXDecoder :: + (B.ByteString -> e -> x) + -> (B.ByteString -> a -> x) + -> CompletedXDecoder e a + -> x +completedXDecoder f _ (CompletedFail b e) = + f b e +completedXDecoder _ d (CompletedDone b a) = + d b a + +_CompletedFail :: + Prism' (CompletedXDecoder e a) (B.ByteString, e) +_CompletedFail = + prism' + (uncurry CompletedFail) + (\x -> case x of + CompletedFail b e -> Just (b, e) + _ -> Nothing) + +_CompletedDone :: + Prism' (CompletedXDecoder e a) (B.ByteString, a) +_CompletedDone = + prism' + (uncurry CompletedDone) + (\x -> case x of + CompletedDone b a -> Just (b, a) + _ -> Nothing) + +completedIso :: + Iso (CompletedXDecoder e a) (CompletedXDecoder f b) (Either e a, B.ByteString) (Either f b, B.ByteString) +completedIso = + iso + (\d -> case d of + CompletedFail b e -> (Left e, b) + CompletedDone b a -> (Right a, b)) + (\z -> case z of + (Left e, b) -> CompletedFail b e + (Right a, b) -> CompletedDone b a) +{-# INLINE completedIso #-} + +completedByteString :: + Lens' (CompletedXDecoder e a) B.ByteString +completedByteString = + lens + (\d -> case d of + CompletedFail b _ -> b + CompletedDone b _ -> b) + (\d b -> case d of + CompletedFail _ e -> CompletedFail b e + CompletedDone _ a -> CompletedDone b a) +{-# INLINE completedByteString #-} + +completedValue :: + Lens' (CompletedXDecoder e a) (Either e a) +completedValue = + lens + (\d -> case d of + CompletedFail _ e -> Left e + CompletedDone _ a -> Right a) + (\d z -> case d of + CompletedFail b e -> CompletedFail b (either id (pure e) z) + CompletedDone b a -> CompletedDone b (either (pure a) id z)) +{-# INLINE completedValue #-} + +instance Functor (CompletedXDecoder e) where + fmap = + bimap id + +instance Bifunctor CompletedXDecoder where + bimap f _ (CompletedFail b e) = + CompletedFail b (f e) + bimap _ g (CompletedDone b a) = + CompletedDone b (g a) + +instance Foldable (CompletedXDecoder e) where + foldMap _ (CompletedFail _ _) = + mempty + foldMap f (CompletedDone _ a) = + f a + +instance Traversable (CompletedXDecoder e) where + traverse = + bitraverse pure + +instance Bifoldable CompletedXDecoder where + bifoldMap f _ (CompletedFail _ e) = + f e + bifoldMap _ g (CompletedDone _ a) = + g a + +instance Bitraversable CompletedXDecoder where + bitraverse f _ (CompletedFail b e) = + fmap (CompletedFail b) (f e) + bitraverse _ g (CompletedDone b a) = + fmap (CompletedDone b) (g a) + +uncomplete :: + Prism' (XDecoder e a) (CompletedXDecoder e a) +uncomplete = + prism' + (\d -> case d of + CompletedFail b e -> XFail b e + CompletedDone b a -> XDone b a) + (\d -> case d of + XFail b e -> Just (CompletedFail b e) + XPartial _ -> Nothing + XDone b a -> Just (CompletedDone b a) + XBytesRead _ _ -> Nothing) +{-# INLINE uncomplete #-} + +uncompletedByteString :: + Traversal' (XDecoder e a) B.ByteString +uncompletedByteString = + uncomplete . completedByteString +{-# INLINE uncompletedByteString #-} + +uncompletedValue :: + Traversal' (XDecoder e a) (Either e a) +uncompletedValue = + uncomplete . completedValue +{-# INLINE uncompletedValue #-} diff --git a/src/Data/Tickle/IsolateError.hs b/src/Data/Tickle/IsolateError.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tickle/IsolateError.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Safe #-} + +module Data.Tickle.IsolateError( + -- * Data type + IsolateError + -- * Reduction +, isolateError + -- * Prisms +, _NegativeSize +, _IsolateXFail +, _UnexpectedConsumed +) where + +import Control.Lens.Prism(prism') +import Control.Lens.Type(Prism') +import Data.Eq(Eq) +import Data.Function(const) +import Data.Functor(Functor(fmap)) +import Data.Functor.Extend(Extend(extended, duplicated)) +import Data.Int(Int) +import Data.Maybe(Maybe(Just, Nothing)) +import Data.Ord(Ord) +import Data.Tuple(uncurry) +import Prelude(Show) + +-- $setup +-- >>> import Control.Lens((#)) +-- >>> import Control.Lens.Fold((^?)) +-- >>> import Data.List(reverse) +-- >>> import Prelude(Num((+), (*))) + +data IsolateError e = + NegativeSize + | IsolateXFail e + | UnexpectedConsumed Int Int + deriving (Eq, Ord, Show) + +-- | +-- +-- >>> isolateError 7 (\_ -> 8) (\_ _ -> 9) (_NegativeSize # ()) +-- 7 +-- +-- >>> isolateError 7 (+10) (\_ _ -> 9) (_IsolateXFail # 99) +-- 109 +-- +-- >>> isolateError 7 (\_ -> 8) (+) (_UnexpectedConsumed # (12, 14)) +-- 26 +isolateError :: + a + -> (e -> a) + -> (Int -> Int -> a) + -> IsolateError e + -> a +isolateError n _ _ NegativeSize = + n +isolateError _ f _ (IsolateXFail e) = + f e +isolateError _ _ u (UnexpectedConsumed m n) = + u m n + +-- | Map a function on the possible failure. +-- +-- >>> fmap (+1) (_NegativeSize # () :: IsolateError Int) +-- NegativeSize +-- +-- >>> fmap reverse (_IsolateXFail # "abc") +-- IsolateXFail "cba" +-- +-- >>> fmap (+1) (_UnexpectedConsumed # (7, 8) :: IsolateError Int) +-- UnexpectedConsumed 7 8 +instance Functor IsolateError where + fmap _ NegativeSize = + NegativeSize + fmap f (IsolateXFail e) = + IsolateXFail (f e) + fmap _ (UnexpectedConsumed m n) = + UnexpectedConsumed m n + +-- | Duplicate on the possible failure. +-- +-- >>> extended (isolateError 12 (+10) (*)) (_IsolateXFail # 99) +-- IsolateXFail 109 +-- +-- >>> extended (isolateError 12 (+10) (*)) (_UnexpectedConsumed # (12, 13)) +-- UnexpectedConsumed 12 13 +-- +-- >>> extended (isolateError 12 (+10) (*)) (_NegativeSize # ()) +-- NegativeSize +instance Extend IsolateError where + extended _ NegativeSize = + NegativeSize + extended f i@(IsolateXFail _) = + IsolateXFail (f i) + extended _ (UnexpectedConsumed m n) = + UnexpectedConsumed m n + duplicated NegativeSize = + NegativeSize + duplicated i@(IsolateXFail _) = + IsolateXFail i + duplicated (UnexpectedConsumed m n) = + UnexpectedConsumed m n + +-- | +-- +-- >>> _NegativeSize # () +-- NegativeSize +-- +-- >>> (_NegativeSize # ()) ^? _NegativeSize +-- Just () +-- +-- >>> (_IsolateXFail # 8) ^? _NegativeSize +-- Nothing +-- +-- >>> (_UnexpectedConsumed # (12, 13)) ^? _NegativeSize +-- Nothing +_NegativeSize :: + Prism' (IsolateError e) () +_NegativeSize = + prism' + (const NegativeSize) + (\x -> case x of + NegativeSize -> Just () + _ -> Nothing) + +-- | +-- +-- >>> _IsolateXFail # 8 +-- IsolateXFail 8 +-- +-- >>> (_NegativeSize # ()) ^? _IsolateXFail +-- Nothing +-- +-- >>> (_IsolateXFail # 8) ^? _IsolateXFail +-- Just 8 +-- +-- >>> (_UnexpectedConsumed # (12, 13)) ^? _IsolateXFail +-- Nothing +_IsolateXFail :: + Prism' (IsolateError e) e +_IsolateXFail = + prism' + IsolateXFail + (\x -> case x of + IsolateXFail e -> Just e + _ -> Nothing) + +-- | +-- +-- >>> _UnexpectedConsumed # (12,13) +-- UnexpectedConsumed 12 13 +-- +-- >>> (_NegativeSize # ()) ^? _UnexpectedConsumed +-- Nothing +-- +-- >>> (_IsolateXFail # 8) ^? _UnexpectedConsumed +-- Nothing +-- +-- >>> (_UnexpectedConsumed # (12, 13)) ^? _UnexpectedConsumed +-- Just (12,13) +_UnexpectedConsumed :: + Prism' (IsolateError e) (Int, Int) +_UnexpectedConsumed = + prism' + (uncurry UnexpectedConsumed) + (\x -> case x of + UnexpectedConsumed l m -> Just (l, m) + _ -> Nothing) diff --git a/src/Data/Tickle/RunGetResult.hs b/src/Data/Tickle/RunGetResult.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tickle/RunGetResult.hs @@ -0,0 +1,416 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Safe #-} + +module Data.Tickle.RunGetResult( + -- * Data type + RunGetResult + -- * Reduction +, runGetResult + -- * Prisms +, _RunGetFail +, _RunGet + -- * Isomorphisms +, runGetResultEitherIso +, runGetResultValidationIso +, runGetResultValidation'Iso +, runGetResultAccValidationIso +) where + +import Control.Applicative(Applicative((<*>), pure), (<$>)) +import Control.Category(Category((.), id)) +import Control.Lens.Iso(iso, from) +import Control.Lens.Prism(prism') +import Control.Lens.Type(Iso, Prism') +import Control.Monad(Monad((>>=), return)) +import Data.Bifoldable(Bifoldable(bifoldMap)) +import Data.Bifunctor(Bifunctor(bimap)) +import Data.Bitraversable(Bitraversable(bitraverse)) +import Data.Either(Either(Left, Right)) +import Data.Eq(Eq) +import Data.Foldable(Foldable(foldMap)) +import Data.Functor(Functor(fmap)) +import Data.Functor.Apply(Apply((<.>))) +import Data.Functor.Alt(Alt(())) +import Data.Functor.Bind(Bind((>>-))) +import Data.Functor.Extend(Extend(extended, duplicated)) +import Data.Int(Int64) +import Data.Maybe(Maybe(Nothing, Just)) +import Data.Monoid(Monoid(mempty)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Data.Traversable(Traversable(traverse)) +import Data.Tuple(uncurry) +import Data.Validation(Validation, AccValidation, Validation', Validate(_Either, _Validation')) +import Prelude(Show) + +-- $setup +-- >>> import Control.Lens((#)) +-- >>> import Control.Lens.Fold((^?)) +-- >>> import Control.Lens.Prism(_Right, _Left) +-- >>> import Data.Eq(Eq((==))) +-- >>> import Data.Int(Int) +-- >>> import Data.List((++)) +-- >>> import Data.String(String) +-- >>> import Data.Validation(_Success, _Failure) +-- >>> import Prelude(Num((*), (+), (-)), subtract, even, mod) + +data RunGetResult e a = + RunGetFail Int64 e + | RunGet a + deriving (Eq, Ord, Show) + +-- | +-- +-- >>> runGetResult (+) (*2) (_RunGet # 12) +-- 24 +-- +-- >>> runGetResult (+) (*2) (_RunGetFail # (23, 12)) +-- 35 +runGetResult :: + (Int64 -> e -> x) + -> (a -> x) + -> RunGetResult e a + -> x +runGetResult f _ (RunGetFail i e) = + f i e +runGetResult _ r (RunGet a) = + r a + +-- | +-- +-- >>> bimap (+10) (*2) (_RunGet # 12) +-- RunGet 24 +-- +-- >>> bimap (+10) (*2) (_RunGetFail # (2, 3)) +-- RunGetFail 2 13 +instance Bifunctor RunGetResult where + bimap f _ (RunGetFail i e) = + RunGetFail i (f e) + bimap _ g (RunGet a) = + RunGet (g a) + +-- | +-- +-- >>> fmap (*2) (_RunGet # 8) +-- RunGet 16 +-- +-- >>> fmap (*2) (_RunGetFail # (9, 13)) +-- RunGetFail 9 13 +instance Functor (RunGetResult e) where + fmap = + bimap id + +-- | +-- +-- >>> bifoldMap (++"abc") (++"def") (_RunGet # "hi") +-- "hidef" +-- +-- >>> bifoldMap (++"abc") (++"def") (_RunGetFail # (12, "hi")) +-- "hiabc" +instance Bifoldable RunGetResult where + bifoldMap f _ (RunGetFail _ e) = + f e + bifoldMap _ g (RunGet a) = + g a + +-- | +-- +-- >>> foldMap (++"abc") (_RunGet # "hi") +-- "hiabc" +-- +-- >>> foldMap (++"abc") (_RunGetFail # (12, "hi")) +-- "" +instance Foldable (RunGetResult e) where + foldMap _ (RunGetFail _ _) = + mempty + foldMap f (RunGet a) = + f a + +-- | +-- +-- >>> bitraverse (\n -> if even n then [n - 1] else [n * 2]) (\n -> if n `mod` 5 == 0 then [n + 1] else [n * 7]) (_RunGet # 8) +-- [RunGet 56] +-- +-- >>> bitraverse (\n -> if even n then [n - 1] else [n * 2]) (\n -> if n `mod` 5 == 0 then [n + 1] else [n * 7]) (_RunGet # 9) +-- [RunGet 63] +-- +-- >>> bitraverse (\n -> if even n then [n - 1] else [n * 2]) (\n -> if n `mod` 5 == 0 then [n + 1] else [n * 7]) (_RunGet # 10) +-- [RunGet 11] +-- +-- λ> bitraverse (\n -> if even n then [n - 1] else [n * 2]) (\n -> if n `mod` 5 == 0 then [n + 1] else [n * 7]) (_RunGetFail # (8, 18)) +-- [RunGetFail 8 17] +-- +-- >>> bitraverse (\n -> if even n then [n - 1] else [n * 2]) (\n -> if n `mod` 5 == 0 then [n + 1] else [n * 7]) (_RunGetFail # (8, 19)) +-- [RunGetFail 8 38] +-- +-- >>> bitraverse (\n -> if even n then [n - 1] else [n * 2]) (\n -> if n `mod` 5 == 0 then [n + 1] else [n * 7]) (_RunGetFail # (8, 20)) +-- [RunGetFail 8 19] +instance Bitraversable RunGetResult where + bitraverse f _ (RunGetFail i e) = + RunGetFail i <$> f e + bitraverse _ g (RunGet a) = + RunGet <$> g a + +-- | +-- +-- >>> traverse (\n -> if n `mod` 5 == 0 then [n + 1] else [n * 7]) (_RunGet # 8) +-- [RunGet 56] +-- +-- >>> traverse (\n -> if n `mod` 5 == 0 then [n + 1] else [n * 7]) (_RunGet # 10) +-- [RunGet 11] +instance Traversable (RunGetResult e) where + traverse = + bitraverse pure + +-- | +-- +-- >>> _RunGet # (*2) <.> _RunGet # 9 +-- RunGet 18 +-- +-- >>> _RunGetFail # (10, 2) <.> _RunGet # 9 +-- RunGetFail 10 2 +-- +-- >>> _RunGet # (*2) <.> _RunGetFail # (11, 3) +-- RunGetFail 11 3 +-- +-- >>> _RunGetFail # (10, 2) <.> _RunGetFail # (11, 3) +-- RunGetFail 10 2 +instance Apply (RunGetResult e) where + RunGet f <.> RunGet a = + RunGet (f a) + RunGet _ <.> RunGetFail i e = + RunGetFail i e + RunGetFail i e <.> _ = + RunGetFail i e + +-- | +-- +-- >>> pure 7 :: RunGetResult () Int +-- RunGet 7 +-- +-- >>> _RunGet # (*2) <*> _RunGet # 9 +-- RunGet 18 +-- +-- >>> _RunGetFail # (10, 2) <*> _RunGet # 9 +-- RunGetFail 10 2 +-- +-- >>> _RunGet # (*2) <*> _RunGetFail # (11, 3) +-- RunGetFail 11 3 +-- +-- >>> _RunGetFail # (10, 2) <*> _RunGetFail # (11, 3) +-- RunGetFail 10 2 +instance Applicative (RunGetResult e) where + RunGet f <*> RunGet a = + RunGet (f a) + RunGet _ <*> RunGetFail i e = + RunGetFail i e + RunGetFail i e <*> _ = + RunGetFail i e + pure = + RunGet + +-- | +-- +-- >>> return 7 :: RunGetResult () Int +-- RunGet 7 +-- +-- >>> _RunGet # 8 >>- \g -> if even g then _RunGet # (g * 2) else _RunGetFail # (13, g * 14) +-- RunGet 16 +-- +-- >>> _RunGet # 9 >>- \g -> if even g then _RunGet # (g * 2) else _RunGetFail # (13, g * 14) +-- RunGetFail 13 126 +-- +-- >>> _RunGetFail # (10, 8) >>- \g -> if even g then _RunGet # (g * 2) else _RunGetFail # (13, g * 14) +-- RunGetFail 10 8 +instance Bind (RunGetResult e) where + RunGet a >>- f = + f a + RunGetFail i e >>- _ = + RunGetFail i e + +-- | +-- +-- >>> _RunGet # 8 >>= \g -> if even g then _RunGet # (g * 2) else _RunGetFail # (13, g * 14) +-- RunGet 16 +-- +-- >>> _RunGet # 9 >>= \g -> if even g then _RunGet # (g * 2) else _RunGetFail # (13, g * 14) +-- RunGetFail 13 126 +-- +-- >>> _RunGetFail # (10, 8) >>= \g -> if even g then _RunGet # (g * 2) else _RunGetFail # (13, g * 14) +-- RunGetFail 10 8 +instance Monad (RunGetResult e) where + RunGet a >>= f = + f a + RunGetFail i e >>= _ = + RunGetFail i e + return = + RunGet + +-- | +-- +-- >>> _RunGet # 8 _RunGet # 9 +-- RunGet 8 +-- +-- >>> _RunGet # 8 _RunGetFail # (10, 9) +-- RunGet 8 +-- +-- >>> _RunGetFail # (10, 8) _RunGet # 9 +-- RunGet 9 +-- +-- >>> _RunGetFail # (10, 8) _RunGet # (20, 9) +-- RunGet (20,9) +instance Alt (RunGetResult e) where + RunGet a _ = + RunGet a + RunGetFail _ _ r = + r + +-- | +-- +-- >>> duplicated (_RunGet # 8) +-- RunGet (RunGet 8) +-- +-- >>> duplicated (_RunGetFail # (9, "abc")) +-- RunGetFail 9 "abc" +instance Extend (RunGetResult e) where + extended _ (RunGetFail i e) = + RunGetFail i e + extended f g@(RunGet _) = + RunGet (f g) + duplicated (RunGetFail i e) = + RunGetFail i e + duplicated g@(RunGet _) = + RunGet g + +-- | +-- +-- >>> _RunGet # 8 <> _RunGet # 9 +-- RunGet 8 +-- +-- >>> _RunGet # 8 <> _RunGetFail # (10, 9) +-- RunGet 8 +-- +-- >>> _RunGetFail # (10, 8) <> _RunGet # 9 +-- RunGet 9 +-- +-- >>> _RunGetFail # (10, 8) <> _RunGet # (20, 9) +-- RunGet (20,9) +instance Semigroup (RunGetResult e a) where + (<>) = + () + +-- | +-- +-- >>> _RunGetFail # (10, "abc") +-- RunGetFail 10 "abc" +-- +-- >>> (_RunGet # 8) ^? _RunGetFail +-- Nothing +-- +-- >>> (_RunGetFail # (8, "abc")) ^? _RunGetFail +-- Just (8,"abc") +_RunGetFail :: + Prism' (RunGetResult e a) (Int64, e) +_RunGetFail = + prism' + (uncurry RunGetFail) + (\x -> case x of + RunGetFail i e -> Just (i, e) + _ -> Nothing) + +-- | +-- +-- >>> :t _RunGet # 8 +-- _RunGet # 8 :: Num b => RunGetResult e b +-- +-- >>> (_RunGet # 8) ^? _RunGet +-- Just 8 +-- +-- >>> (_RunGetFail # (8, "abc")) ^? _RunGet +-- Nothing +_RunGet :: + Prism' (RunGetResult e a) a +_RunGet = + prism' + RunGet + (\x -> case x of + RunGet a -> Just a + _ -> Nothing) + +-- | +-- +-- >>> runGetResultEitherIso # Right 99 +-- RunGet 99 +-- +-- >>> runGetResultEitherIso # Left (12, "abc") +-- RunGetFail 12 "abc" +-- +-- >>> from runGetResultEitherIso # _RunGet # 99 +-- Right 99 +-- +-- >>> from runGetResultEitherIso # _RunGetFail # (12, "abc") +-- Left (12,"abc") +runGetResultEitherIso :: + Iso (RunGetResult a b) (RunGetResult b d) (Either (Int64, a) b) (Either (Int64, b) d) +runGetResultEitherIso = + iso + (\r -> case r of + RunGetFail i a -> Left (i, a) + RunGet b -> Right b) + (\e -> case e of + Left (i, a) -> RunGetFail i a + Right b -> RunGet b) + +-- | +-- +-- >>> runGetResultValidationIso # _Success # 99 +-- RunGet 99 +-- +-- >>> runGetResultValidationIso # _Failure # (12, "abc") +-- RunGetFail 12 "abc" +-- +-- >>> from runGetResultValidationIso # _RunGet # 99 +-- Success 99 +-- +-- >>> from runGetResultValidationIso # _RunGetFail # (12, "abc") +-- Failure (12,"abc") +runGetResultValidationIso :: + Iso (RunGetResult a b) (RunGetResult b d) (Validation (Int64, a) b) (Validation (Int64, b) d) +runGetResultValidationIso = + from (_Either . from runGetResultEitherIso) + +-- | +-- +-- >>> runGetResultValidation'Iso . from _Validation' # _Right # 99 +-- RunGet 99 +-- +-- >>> runGetResultValidation'Iso . from _Validation' # _Left # (12, "abc") +-- RunGetFail 12 "abc" +-- +-- >>> from (runGetResultValidation'Iso . from _Validation') # _RunGet # 99 :: Validation (Int64, ()) Int +-- Success 99 +-- +-- >>> from (runGetResultValidation'Iso . from _Validation') # _RunGetFail # (12, "abc") :: Validation (Int64, String) () +-- Failure (12,"abc") +runGetResultValidation'Iso :: + Iso (RunGetResult a b) (RunGetResult b d) (Validation' (Int64, a) b) (Validation' (Int64, b) d) +runGetResultValidation'Iso = + from (from _Validation' . from runGetResultEitherIso) + +-- | +-- +-- >>> runGetResultAccValidationIso # _Success # 99 +-- RunGet 99 +-- +-- >>> runGetResultAccValidationIso # _Failure # (12, "abc") +-- RunGetFail 12 "abc" +-- +-- >>> from runGetResultAccValidationIso # _RunGet # 99 +-- AccSuccess 99 +-- +-- >>> from runGetResultAccValidationIso # _RunGetFail # (12, "abc") +-- AccFailure (12,"abc") +runGetResultAccValidationIso :: + Iso (RunGetResult a b) (RunGetResult b d) (AccValidation (Int64, a) b) (AccValidation (Int64, b) d) +runGetResultAccValidationIso = + from (_Either . from runGetResultEitherIso) diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,32 @@ +module Main where + +import Build_doctests (deps) +import Control.Applicative +import Control.Monad +import Data.List +import System.Directory +import System.FilePath +import Test.DocTest + +main :: + IO () +main = + getSources >>= \sources -> doctest $ + "-isrc" + : "-idist/build/autogen" + : "-optP-include" + : "-optPdist/build/autogen/cabal_macros.h" + : "-hide-all-packages" + : map ("-package="++) deps ++ sources + +getSources :: IO [FilePath] +getSources = filter (isSuffixOf ".hs") <$> go "src" + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c diff --git a/tickle.cabal b/tickle.cabal new file mode 100644 --- /dev/null +++ b/tickle.cabal @@ -0,0 +1,81 @@ +name: tickle +version: 0.0.1 +license: BSD3 +license-file: LICENSE +author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +maintainer: Tony Morris +copyright: Copyright (C) 2014 NICTA Limited +synopsis: A port of @Data.Binary@ +category: Data +description: + <> + . + A port of @Data.Binary@ that tightens up data types and parameterises error messages +homepage: https://github.com/tonymorris/tickle +bug-reports: https://github.com/tonymorris/tickle/issues +cabal-version: >= 1.10 +build-type: Custom +extra-source-files: changelog, etc/ATTRIBUTIONS + +source-repository head + type: git + location: git@github.com:tonymorris/tickle.git + +flag small_base + description: Choose the new, split-up base package. + +library + default-language: + Haskell2010 + + build-depends: + base < 5 && >= 3 + , semigroups >= 0.8 + , semigroupoids >= 4.2 + , bifunctors >= 3.0 + , lens >= 4.3.3 + , bytestring >= 0.10 + , transformers >= 0.3.0.0 + , mtl >= 2.1 + , validation >= 0.3.4 + + ghc-options: + -Wall + + default-extensions: + + NoImplicitPrelude + + hs-source-dirs: + src + + exposed-modules: + Data.Tickle + Data.Tickle.Get + Data.Tickle.IsolateError + Data.Tickle.RunGetResult + +test-suite doctests + type: + exitcode-stdio-1.0 + + main-is: + doctests.hs + + default-language: + Haskell2010 + + build-depends: + base < 5 && >= 3 + , doctest >= 0.9.7 + , filepath >= 1.3 + , directory >= 1.1 + , QuickCheck >= 2.0 + , template-haskell >= 2.8 + + ghc-options: + -Wall + -threaded + + hs-source-dirs: + test