arrow-utils (empty) → 0.1.0.0

raw patch · 5 files changed

+214/−0 lines, 5 filesdep +QuickCheckdep +arrow-utilsdep +base

Dependencies added: QuickCheck, arrow-utils, base, test-framework, test-framework-quickcheck2, vector-sized

Files

• CHANGELOG.md +5/−0
• LICENSE +30/−0
• arrow-utils.cabal +41/−0
• src/Control/Arrow/Utils.hs +110/−0
• test/Main.hs +28/−0

@@ -0,0 +1,5 @@+# Revision history for arrow-utils++## 0.1.0.0 -- 2021-06-?++* First version.

@@ -0,0 +1,30 @@+Copyright (c) 2021, Miguel Negrão++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Miguel Negrão nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,41 @@+cabal-version:      >=1.10+name:               arrow-utils+version:            0.1.0.0+synopsis: functions for working with arrows+description:+ arrow-utils provides useful functions and type classes for working with arrows. It provides functions similar to sequenceA.+++license:            BSD3+license-file:       LICENSE+author:             Miguel Negrão+maintainer:         miguel.negrao@friendlyvirus.org+homepage:           https://github.com/miguel-negrao/+category:           Arrows, Control, Combinators+build-type:         Simple+extra-source-files: CHANGELOG.md++library+    exposed-modules:+        Control.Arrow.Utils+    other-extensions:+        Arrows+    build-depends:+          base  == 4.14.* +        , vector-sized == 1.4.*+    hs-source-dirs:   src+    default-language: Haskell2010+++test-suite test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: test+  build-depends:+      base  == 4.14.*+    , arrow-utils+    , test-framework == 0.8.*+    , test-framework-quickcheck2 == 0.3.*+    , QuickCheck == 2.14.*+    +  default-language:    Haskell2010

@@ -0,0 +1,110 @@+{-# LANGUAGE Arrows #-}++module Control.Arrow.Utils (+    SameInputArrow(..)+  , traverseArr+  , traverseArr_+  , sequenceArr_+  , sequenceArr+  , zipSequenceArrVec+  , zipSequenceArrList+  , whenArr+  , unlessArr+  , constantly+) where++import Control.Arrow+    ( returnA, (>>>), Arrow((***), arr), ArrowChoice )+import Data.Foldable (traverse_)+import Data.Maybe ( fromJust )+import Data.Vector.Sized ( fromList, toList, Vector )+import qualified Data.Vector.Sized as Vec+import GHC.TypeLits ( KnownNat )++-- | Wrap the Arrow in a newtype in order to create new class instances.+--   This is a generalisation of 'ArrowMonad',+--   which is isomorphic to @'SameInputArrow' a () c@.+newtype SameInputArrow a b c = SameInputArrow { unSameInputArrow :: a b c }++-- | @'fmap' f@ postcomposes with @f@+instance (Arrow a) => Functor (SameInputArrow a b) where+  fmap f a = SameInputArrow (unSameInputArrow a >>> arr f)++-- | @'<*>'@ runs the arrows in parallel+instance (Arrow a) => Applicative (SameInputArrow a b) where+  pure c = SameInputArrow $ constantly c+  f <*> a = SameInputArrow $ proc input -> do+    fres <- unSameInputArrow f -< input+    ares <- unSameInputArrow a -< input+    returnA -< fres ares++-- | Creates arrows using f, then runs all arrows in the given 'Foldable',+-- discarding the results.+traverseArr_ :: (Foldable t, Arrow a) => (x -> a b c) -> t x -> a b ()+traverseArr_ f xs = unSameInputArrow $ traverse_ (SameInputArrow . f) xs++-- | Creates arrows using f, then runs all arrows in the given 'Traversable',+-- collecting the results.+--+--   @traverseArr (+) [1,10] 1 == [2,11]@+traverseArr :: (Traversable t, Arrow a) => (x -> a b c) -> t x -> a b (t c)+traverseArr f xs = unSameInputArrow $ traverse (SameInputArrow . f) xs++-- | Like 'sequenceArr', but discard the results.+sequenceArr_ :: (Foldable t, Arrow a) => t (a b any) -> a b ()+sequenceArr_ = traverseArr_ id++-- | Run all arrows in the given 'Traversable', collecting the results.+--+--   @sequenceArr [(+1), (+10)] 1 == [2,11]@+sequenceArr :: (Traversable t, Arrow a) => t (a b c) -> a b (t c)+sequenceArr = traverseArr id++-- | Fans each input from @Vector n b@ to a separate arrow from the given vector.+--+--   @sequenceArrVec (Vec.generate ((+).fromIntegral) :: Vector 5 (Int -> Int)) (Vec.replicate 1 :: Vector 5 Int) == Vector [1,2,3,4,5]@+zipSequenceArrVec :: (Arrow a, KnownNat n) => Vector n (a b c) -> a (Vector n b) (Vector n c)+zipSequenceArrVec cells = arr toList >>> zipSequenceArrListUnsafe (toList cells) >>> arr (fromJust . fromList)++-- Not safe, doesn't check size of the lists.+-- When used in sequenceArrVec it is safe as the size of the+-- vectors are all the same. Not to export.+zipSequenceArrListUnsafe :: Arrow a => [a b c] -> a [b] [c]+zipSequenceArrListUnsafe [] = constantly []+zipSequenceArrListUnsafe (x:xs) = proc (y:ys) -> do+  xres <- x -< y+  xsres <- zipSequenceArrListUnsafe xs -< ys+  returnA -< (xres:xsres)++-- | Fans each input from @[b]@ to a separate arrow from the given list.+--   The output list has length of the minimum of the input list length and the arrow list length.+--+--  @+--  sequenceArrList [(+1), (+10)] [1,2] == [2,12]+--  sequenceArrList [(+1), (+10)] [1]   == [2]+--  sequenceArrList [(+1)] [1,2,3,4]    == [2]@+zipSequenceArrList :: (Arrow a, ArrowChoice a) => [a b c] -> a [b] [c]+zipSequenceArrList [] = constantly []+zipSequenceArrList (a : as) = proc bs' -> case bs' of+  [] -> returnA -< []+  b : bs -> do+    c <- a -< b+    cs <- zipSequenceArrList as -< bs+    returnA -< c : cs++-- | Similar to @'when'@ for @'Applicative'@. Relevant for+--   arrows which embeded a Monad.+whenArr :: ArrowChoice a => a b () -> a (Bool, b) ()+whenArr cell = proc (b, input) -> do+  if b+    then cell -< input+    else constantly () -< input++-- | Similar to @'unless'@ for @'Applicative'@. Relevant for+--   arrows which embeded a Monad.+unlessArr :: ArrowChoice a => a b () -> a (Bool, b) ()+unlessArr cell = arr not *** arr id >>> whenArr cell++-- | Always output the given value.+constantly :: Arrow a => b -> a any b+constantly = arr . const

@@ -0,0 +1,28 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- test-framework+import Test.Framework ( testGroup, defaultMain, Test )++-- test-framework-quickcheck2+import Test.Framework.Providers.QuickCheck2 ( testProperty )++-- QuickCheck+import Test.QuickCheck ( (===) )++import Control.Arrow.Utils ( zipSequenceArrList )++main :: IO ()+main = defaultMain tests++tests :: [Test.Framework.Test]+tests = [+  testGroup "sequenceArrList"+    [ testProperty "length of arrows"+      $ \(xs :: [Integer]) (ys :: [Integer])-> let+         funcList = fmap (const (+1)) ys+         res = zipSequenceArrList funcList xs+        in+          length res === min (length xs) (length ys)                           +    ]+  ]+