diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/space.hs b/bench/space.hs new file mode 100644 --- /dev/null +++ b/bench/space.hs @@ -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] diff --git a/bench/time.hs b/bench/time.hs new file mode 100644 --- /dev/null +++ b/bench/time.hs @@ -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] + ) + ] diff --git a/grab.cabal b/grab.cabal new file mode 100644 --- /dev/null +++ b/grab.cabal @@ -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 diff --git a/license.txt b/license.txt new file mode 100644 --- /dev/null +++ b/license.txt @@ -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. diff --git a/src/Control/Grab.hs b/src/Control/Grab.hs new file mode 100644 --- /dev/null +++ b/src/Control/Grab.hs @@ -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 diff --git a/test/hedgehog.hs b/test/hedgehog.hs new file mode 100644 --- /dev/null +++ b/test/hedgehog.hs @@ -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