grab (empty) → 0.0.0.1
raw patch · 7 files changed
+743/−0 lines, 7 filesdep +basedep +criteriondep +grabsetup-changed
Dependencies added: base, criterion, grab, hedgehog
Files
- Setup.hs +2/−0
- bench/space.hs +39/−0
- bench/time.hs +27/−0
- grab.cabal +129/−0
- license.txt +18/−0
- src/Control/Grab.hs +373/−0
- test/hedgehog.hs +155/−0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/space.hs view
@@ -0,0 +1,39 @@+{-# OPTIONS_GHC -Wall #-}++{-# LANGUAGE ApplicativeDo, BlockArguments #-}++import Prelude hiding ((/))++import qualified Control.Grab as Grab+import Control.Grab ((/))++import qualified Data.List as List+import qualified Data.Foldable as Foldable++import Data.Monoid++main :: IO ()+main =+ do+ let r = Grab.runGrab g [1..30000]+ putStrLn ("desideratum: " ++ show (Grab.desideratum r))+ putStrLn ("log: " ++ show (Grab.log r))++f :: Monoid log => (a -> Bool) -> Grab.Simple [a] log [a]+f p = Grab.partition (List.partition p)++g :: Grab.Simple [Integer] (Sum Integer) (Integer, Integer)+g =+ do+ _ <- Foldable.for_ primes \n ->+ ( f (\x -> mod x n == 0)+ / Grab.dump (\xs -> Grab.warning (Sum $! sum xs))+ )++ evenSum <- sum <$> f even+ oddSum <- sum <$> f odd++ pure (evenSum, oddSum)++primes :: [Integer]+primes = [5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79]
+ bench/time.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS_GHC -Wall #-}++import qualified Control.Grab as Grab++import Criterion.Main++import qualified Data.List as List+import Prelude hiding (filter)++parity :: Integer -> Maybe (Integer, Integer)+parity n = Grab.desideratum (Grab.runGrab g [1..n])+ where+ g = (,) <$> (sum <$> filter even) <*> (sum <$> filter odd)++filter :: (a -> Bool) -> Grab.Simple [a] () [a]+filter p = Grab.partition (List.partition p)++main :: IO ()+main = defaultMain [+ bgroup "parity"+ (+ (\i -> let n = i * 10000 in+ bench (show i) (nf parity n)+ )+ <$> [1..4]+ )+ ]
+ grab.cabal view
@@ -0,0 +1,129 @@+cabal-version: 2.4++name: grab+version: 0.0.0.1++synopsis: Applicative non-linear consumption+category: Control++description:+ == The Grab type+ .+ A grab consumes some portion (none, part, or all) of+ its input @bag@, and returns a @residue@ consisting of+ the unconsumed input, some monoidal @log@ (e.g. a list+ of error messages), and some @desideratum@ (the object+ of desire) produced from the consumed input, or+ @Nothing@ if the grab failed.+ .+ > newtype Grab bag residue log desideratum =+ > Grab (+ > bag -> (residue, log, Maybe desideratum)+ > )+ .+ Grabs are useful as parsers for inputs such as JSON+ objects or lists of form parameters, where the input data+ is not necessarily given linearly in the same order in+ which we want to consume it.+ .+ == Applicative composition+ .+ A @Simple@ grab (where the @bag@ and @residue@ are the+ same type) has an @Applicative@ instance.+ .+ > instance (bag ~ residue, Monoid log) =>+ > Applicative (Grab bag residue log)+ .+ For example, we can create two simple list grabs, one that+ grabs multiples of two, and the other that grabs multiples+ of three:+ .+ > twos, threes :: Monoid log =>+ > Control.Grab.Simple [Integer] log [Integer]+ > twos = partition (Data.List.partition (\x -> mod x 2 == 0))+ > threes = partition (Data.List.partition (\x -> mod x 3 == 0))+ .+ > λ> runGrabMaybe ((,) <$> twos @() <*> threes @()) [1..10]+ > Just ([2,4,6,8,10],[3,9])+ .+ Notice that the second part of the resulting tuple contains only+ the /odd/ multiples of three. Because @twos@ runs first, it+ consumes @6@ before the @threes@ can get it.+ .+ == Pipeline composition+ .+ @a / b@ is a pipeline of two grabs, where the desideratum from+ @a@ is the @bag@ for @b@.+ .+ > (/) :: Semigroup log+ > => Grab bag residue log x+ > -> Grab x _residue log desideratum+ > -> Grab bag residue log desideratum+ .+ > λ> runGrabMaybe (twos @() / threes @()) [1..10]+ > Just [6]+ .+ > λ> runGrabMaybe ((,) <$> (twos @() / threes @()) <*> threes @()) [1..10]+ > Just ([6],[3,9])++homepage: https://github.com/typeclasses/grab+bug-reports: https://github.com/typeclasses/grab/issues++author: Chris Martin+maintainer: Chris Martin, Julie Moronuki++copyright: 2019 Typeclass Consulting, LLC+license: MIT+license-file: license.txt++tested-with: GHC==8.6.5++library+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -fdefer-typed-holes+ exposed-modules: Control.Grab++ build-depends:+ base ^>= 4.12.0.0++test-suite hedgehog+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: hedgehog.hs++ build-depends:+ grab+ , base ^>= 4.12.0.0+ , hedgehog ^>= 0.6.1++-- This benchmark runs with a tightly limited stack size+-- to detect space leaks, as described by:+-- http://neilmitchell.blogspot.com/2015/09/detecting-space-leaks.html+--+-- Run it like this for a stack trace:+--+-- stack bench grab:space --profile --ba "+RTS -xc"+--+benchmark space+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: space.hs+ default-language: Haskell2010+ ghc-options: "-with-rtsopts=-K1K"++ build-depends:+ grab+ , base ^>= 4.12.0.0++benchmark time+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: time.hs+ default-language: Haskell2010++ build-depends:+ grab+ , base ^>= 4.12.0.0+ , criterion ^>= 1.5.5.0
+ license.txt view
@@ -0,0 +1,18 @@+Copyright 2019 Typeclass Consulting, LLC++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ src/Control/Grab.hs view
@@ -0,0 +1,373 @@+{-# OPTIONS_GHC -Wall #-}++{-# LANGUAGE++ BangPatterns, BlockArguments, DeriveFunctor,+ DerivingStrategies, GADTs, LambdaCase,+ ScopedTypeVariables, StandaloneDeriving,+ TypeApplications++#-}++module Control.Grab+ (+ -- * Types+ -- ** The Grab type+ Grab (..)+ -- ** Aliases: Simple, Dump, Result, Extract+ , Simple, Dump, Result, Extract++ -- * Creation+ -- ** Making grabs+ , partition, (/)+ -- ** Making dumps+ , dump, discardResidue+ -- ** Making extracts+ , success, failure, warning, extract++ -- * Use+ -- ** Applying a grab to an input+ , runGrab, runDump+ -- ** Deconstructing results+ , residue, log, desideratum+ -- ** Both applying and deconstructing+ , runGrabMaybe++ ) where++import Control.Applicative (Applicative (..))+import Data.Bifunctor (Bifunctor (..))+import Data.Function ((.))+import Data.Functor (Functor (..))+import Data.Maybe (Maybe (..))+import Data.Monoid (Monoid (..))+import Data.Semigroup (Semigroup (..))+import Prelude ()+++--- The Grab type ---++{- |++A 'Grab':++ 1. Consumes some portion (none, part, or all) of its input+ __@bag@__;++ 2. Returns a 'Result':++ * A __@residue@__ consisting of the unconsumed input;++ * Some monoidal __@log@__ e.g. a list of error messages;++ * Some __@desideratum@__ (the object of desire) produced from+ the consumed input, or @Nothing@ if the grab failed.++Specializations of this type:++ * If the bag and residue types are the same, the grab+ is a __'Simple'__ grab and it has an 'Applicative' instance.++ * If the residue is @()@, the grab is a __'Dump'__; it+ dumps out the entire bag so there is nothing remaining.++ * If the bag is @()@, the grab is just a single fixed+ __'Result'__, which consists of the residue, log, and+ maybe the desideratum.++ * If both the bag and residue are @()@, the grab is+ just the __'Extract'__, which consists of the log and+ maybe the desideratum.++-}++newtype Grab bag residue log desideratum =+ Grab+ (bag -> (residue, log, Maybe desideratum))+++--- Type aliases ---++{- |++A 'Simple' grab:++ 1. Consumes some portion (none, part, or all) of its input+ __@bag@__;++ 2. Returns a 'Result':++ * A modified __@bag@__ representing the unconsumed+ portion of the input;++ * Some monoidal __@log@__ e.g. a list of error messages;++ * Some __@desideratum@__ (the object of desire) produced from+ the consumed input, or @Nothing@ if the grab failed.++-}++type Simple bag log desideratum = Grab bag bag log desideratum++{- | A 'Dump':++ 1. Consumes all of its input __@bag@__;++ 2. Returns a 'Extract':++ * Some monoidal __@log@__ e.g. a list of error messages;++ * Some __@desideratum@__ (the object of desire) produced from+ the consumed input, or @Nothing@ if the grab failed.+-}++type Dump bag log desideratum = Grab bag () log desideratum++{- | The result of performing a 'Grab'. Consists of:++ * A __@residue@__ consisting of the unconsumed input;++ * Some monoidal __@log@__ e.g. a list of error messages;++ * Some __@desideratum@__ (the object of desire) produced from+ the consumed input, or @Nothing@ if the grab failed.+-}++type Result residue log desideratum = Grab () residue log desideratum++{- | What is produced by performing a 'Dump'. Consists of:++ * Some monoidal __@log@__ e.g. a list of error messages;++ * Some __@desideratum@__ (the object of desire) produced from+ the consumed input, or @Nothing@ if the grab failed.+-}++type Extract log desideratum = Grab () () log desideratum+++--- Functor ---++deriving stock instance Functor (Grab bag residue log)+++--- Applicative functor ---++instance (bag ~ residue, Monoid log) =>+ Applicative (Grab bag residue log)+ where+ pure = grabPure+ (<*>) = grabAp++grabPure :: forall bag log desideratum. Monoid log =>+ desideratum -> Grab bag bag log desideratum++grabPure x = Grab \bag -> (bag, mempty, Just x)++grabAp :: forall bag log x desideratum. Monoid log =>+ Grab bag bag log (x -> desideratum) ->+ Grab bag bag log x ->+ Grab bag bag log desideratum++grabAp (Grab pf) (Grab px) =+ Grab \bag ->+ let+ (bag', log1, f) = pf bag+ (bag'', log2, x) = px bag'+ in+ (bag'', log1 <> log2, f <*> x)+++--- Bifunctor ---++instance Bifunctor (Grab bag residue)+ where+ bimap = bimapGrab++bimapGrab :: forall bag residue log log' a a'.+ (log -> log') -> (a -> a') ->+ Grab bag residue log a ->+ Grab bag residue log' a'++bimapGrab f g (Grab x) =+ Grab \bag ->+ let+ (bag', lg, a) = x bag+ in+ (bag', f lg, fmap @Maybe g a)+++--- Creating grabs ---++-- | The most general way to construct an 'Extract'.+extract :: forall log desideratum.+ log+ -- ^ Log output, such as an error or warning message.+ -> Maybe desideratum+ -- ^ 'Just' some desideratum if the extract represents the+ -- outcome of a successful grab, or 'Nothing' if it+ -- represents failure.+ -> Extract log desideratum+ -- ^ An extract consisting of the given log and desideratum.++extract x y = Grab \() -> ((), x, y)++success :: forall log desideratum. Monoid log =>+ desideratum+ -- ^ The desired object.+ -> Extract log desideratum+ -- ^ A successful extract with an empty log.++failure :: forall log desideratum.+ log+ -- ^ Log output such as an error message.+ -> Extract log desideratum+ -- ^ An extract with the given log and no desideratum.++warning :: forall log.+ log+ -- ^ Log output such as a warning message.+ -> Extract log ()+ -- ^ An extract with the given log and a desideratum of @()@.++success x = extract mempty (Just x)+failure x = extract x (Nothing)+warning x = extract x (Just ())++partition :: forall bag residue log desideratum. Monoid log =>+ (bag -> (desideratum, residue))+ -- ^ Function that partitions the bag into desideratum and residue.+ -> Grab bag residue log desideratum+ -- ^ A grab that always succeeds and never logs.++partition f =+ Grab \i ->+ let+ (s, r) = f i+ in+ (r, mempty, Just s)++dump :: forall bag log desideratum.+ (bag -> Extract log desideratum)+ -- ^ A function which, given the entire input, produces+ -- some log output and maybe a desideratum.+ -> Dump bag log desideratum+ -- ^ A grab that consumes the entire bag, producing+ -- whatever the function extracted from its contents.++dump f =+ Grab \i ->+ let+ p = f i+ in+ ((), log p, desideratum p)++-- | @a / b@ is a pipeline of two grabs, using the output of /a/+-- as the input to /b/.+(/) :: forall bag residue _r log x desideratum. Semigroup log =>+ Grab bag residue log x+ -- ^ The first grab /a/, whose desideratum @x@ will be+ -- passed as input to the second grab /b/.+ -> Grab x _r log desideratum+ -- ^ The second grab /b/. The residue of this grab will be+ -- ignored, so it usually ought to be a 'Dump'.+ -> Grab bag residue log desideratum+ -- ^ A grab whose result is the residue of /a/, the combined+ -- logs of both /a/ and /b/, and the desideratum of /b/.++(/) (Grab f) (Grab g) =+ Grab \i ->+ let+ (x, y, z) = f i+ in+ case z of+ Nothing -> (x, y, Nothing)+ Just a ->+ let+ (_, y', z') = g a+ in+ (x, y <> y', z')++discardResidue :: forall bag residue log desideratum .+ Grab bag residue log desideratum+ -- ^ A grab which may produce some residue.+ -> Dump bag log desideratum+ -- ^ A grab that produces no residue.++discardResidue (Grab f) =+ Grab \bag ->+ let+ (_, y, z) = f bag+ in+ ((), y, z)+++--- Using grabs ---++-- | When @residue@ is @()@, this function specializes to 'runDump'.+runGrab :: forall bag residue log desideratum.+ Grab bag residue log desideratum+ -- ^ A grab, which may consume some portion of the input.+ -> bag+ -- ^ The input.+ -> Result residue log desideratum+ -- ^ The result of performing the grab, which consists of+ -- the @residue@ representing the remaining portion of+ -- input, a @log@ for providing error output, and a+ -- @desideratum@ if the grab was successful.++runGrab (Grab f) x =+ let+ !r = f x+ in+ Grab \() -> r++-- | This is a specialization of the more general 'runGrab' function.+runDump :: forall bag log desideratum.+ Dump bag log desideratum+ -- ^ A dump which consumes the input.+ -> bag+ -- ^ The input.+ -> Extract log desideratum+ -- ^ The result extracted from the input, which+ -- consists of a @log@ for providing error output+ -- and a @desideratum@ if the grab was successful.++runDump = runGrab++-- | Run a grab, ignoring the residue and log, producing only+-- the desideratum.+--+-- > runGrabMaybe x = desideratum . runGrab x+--+runGrabMaybe :: forall bag residue log desideratum.+ Grab bag residue log desideratum+ -> bag+ -> Maybe desideratum++runGrabMaybe x = desideratum . runGrab x++desideratum :: forall residue log desideratum.+ Result residue log desideratum+ -- ^ Either a 'Result' or an 'Extract'.+ -> Maybe desideratum+ -- ^ The desired object, if one was successfully+ -- extracted from the bag.++log :: forall residue log desideratum.+ Result residue log desideratum+ -- ^ Either a 'Result' or an 'Extract'.+ -> log+ -- ^ Any extra information produced during the+ -- grab, such as error messages.++residue :: forall residue log desideratum.+ Result residue log desideratum+ -- ^ The result of 'run'ning a 'Grab'+ -> residue+ -- ^ The portion of the bag that was not consumed+ -- by the grab.++residue (Grab f) = let (x, _, _) = f () in x+log (Grab f) = let (_, x, _) = f () in x+desideratum (Grab f) = let (_, _, x) = f () in x
+ test/hedgehog.hs view
@@ -0,0 +1,155 @@+{-# OPTIONS_GHC++ -Wall+ -fno-warn-unused-imports+ -fno-warn-missing-signatures++#-}++{-# LANGUAGE++ BlockArguments, LambdaCase, OverloadedStrings,+ ScopedTypeVariables, TemplateHaskell, ViewPatterns++#-}++import qualified Control.Grab as Grab+import Control.Grab ((/))++import Prelude hiding ((/))++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Control.Monad (when)+import qualified Data.List as List++import System.IO (hSetEncoding, stdout, stderr, utf8)+import System.Exit (exitFailure)++tests :: IO Bool+tests =+ checkParallel $$(discover)++example =+ withTests 1 . property++x ~> y =+ example (x === y)++main :: IO ()+main =+ do+ hSetEncoding stdout utf8+ hSetEncoding stderr utf8+ ok <- tests+ when (not ok) exitFailure++prop_1 =+ let+ r = Grab.failure "a" *>+ Grab.failure "b" *>+ Grab.failure "c"+ :: Grab.Extract String Integer+ in+ (Grab.log r, Grab.desideratum r)+ ~>+ ("abc", Nothing)++prop_2 =+ let+ r = Grab.failure "a" *>+ Grab.failure "b" *>+ Grab.success (4 :: Integer)+ in+ (Grab.log r, Grab.desideratum r )+ ~>+ ("ab" :: String, Nothing)++prop_3 =+ let+ r = Grab.success 4 :: Grab.Extract String Integer+ in+ Grab.desideratum r ~> Just 4++prop_4 =+ let+ g :: Grab.Simple [Integer] () (Integer, Integer)+ g =+ (,)+ <$> ( Grab.partition (List.partition even)+ / Grab.dump (\_ -> Grab.failure ())+ )+ <*> ( Grab.partition (List.partition odd)+ / Grab.dump (\xs -> Grab.success (sum xs))+ )++ r = Grab.runGrab g undefined++ in+ Grab.desideratum r ~> Nothing++prop_5 =+ let+ g :: Grab.Simple [Integer] () (Integer, Integer)+ g =+ (,)+ <$> ( Grab.partition (List.partition even)+ / Grab.dump (\xs -> Grab.success (sum xs))+ )+ <*> ( Grab.partition (List.partition odd)+ / Grab.dump (\_ -> Grab.failure ())+ )++ r = Grab.runGrab g undefined++ in+ Grab.desideratum r ~> Nothing++prop_6 =+ let+ g :: Grab.Simple [Integer] () Integer+ g =+ ( Grab.partition (List.partition even)+ / Grab.dump (\xs -> Grab.success (sum xs))+ )++ r = Grab.runGrab g [1,2,3,4]++ in+ Grab.desideratum r ~> Just 6++prop_7 =+ let+ g :: Grab.Simple [Integer] () (Integer, Integer)+ g =+ (,)+ <$> ( Grab.partition (List.partition even)+ / Grab.dump (\xs -> Grab.success (sum xs))+ )+ <*> ( Grab.partition (List.partition odd)+ / Grab.dump (\xs -> Grab.success (sum xs))+ )++ r = Grab.runGrab g [1,2,3,4]++ in+ Grab.desideratum r ~> Just (6, 4)++prop_8 =+ let+ g :: Grab.Simple [Integer] () (Integer, Integer)+ g =+ (,)+ <$> ( Grab.partition (List.partition even)+ / Grab.dump (\xs -> Grab.success (sum xs))+ )+ <*> ( Grab.partition (List.partition odd)+ / Grab.dump (\xs -> if elem 3 xs then Grab.failure () else Grab.success (sum xs))+ )++ r = Grab.runGrab g (1:2:3:undefined)++ in+ Grab.desideratum r ~> Nothing