arrow-improve (empty) → 0.1.0.0

raw patch · 4 files changed

+374/−0 lines, 4 filesdep +arrowsdep +basedep +pointedsetup-changed

Dependencies added: arrows, base, pointed, profunctors, semigroupoids

Files

Control/Arrow/Improve.hs +328/−0
LICENSE +20/−0
Setup.hs +2/−0
arrow-improve.cabal +24/−0

+ Control/Arrow/Improve.hs view

@@ -0,0 +1,328 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}++-- |Improved arrows, with a whole host of minor optimisations and instances.+module Control.Arrow.Improve(ImproveArrow, lowerImprove, getFunction) where++import Prelude hiding (id, (.))++import Control.Category+import Control.Arrow++import Control.Applicative+import Control.Monad+import Control.Monad.Zip++import Control.Arrow.Transformer+import Control.Arrow.Operations++import Data.Profunctor+import Data.Semigroupoid+import Data.Functor.Plus+import Data.Functor.Bind+import Data.Pointed++import Data.Monoid+import Data.String++-- |Basic improved arrow type.+data ImproveArrow a b c where+  IArr   :: (b -> c)                      -> ImproveArrow a b c+  IArrow :: (i -> b) -> a b c -> (c -> o) -> ImproveArrow a i o++-- |Lower an improved arrow to the original arrow type.+--+-- prop>  lowerImprove . lift = id+-- prop>  lift . lowerImprove = id+lowerImprove :: (Arrow a) => ImproveArrow a b c -> a b c+lowerImprove (IArrow f a g) = f ^>> a >>^ g+lowerImprove (IArr f)       = arr f++-- |Get a function representing the arrow, if it is possible to do so.+-- Guarantees are only made when arrows are constructed only from the+-- combinators of the Category, Arrow, ArrowChoice and ArrowLoop classes.+getFunction :: ImproveArrow a b c -> Maybe (b -> c)+getFunction (IArr f)       = Just f+getFunction (IArrow _ _ _) = Nothing++instance (Arrow a) => Category (ImproveArrow a) where+  id = arr id+  {-# INLINE id #-}+  IArr f . IArr g             = IArr (f . g)+  IArr h . IArrow f a g       = IArrow f a (h . g)+  IArrow f a g . IArr h       = IArrow (f . h) a g+  IArrow f a g . IArrow h b i = IArrow h (b >>> arr (f . i) >>> a) g+  {-# INLINABLE (.) #-}++instance (Arrow a) => Arrow (ImproveArrow a) where+  arr = IArr+  {-# INLINE arr #-}++  first (IArr f) = IArr (first f)+  first (IArrow f a g) = IArrow (first f) (first a) (first g)+  {-# INLINABLE first #-}++  second (IArr f) = IArr (second f)+  second (IArrow f a g) = IArrow (second f) (second a) (second g)+  {-# INLINABLE second #-}++  IArr f *** IArr g             = IArr   (f *** g)+  IArr h *** IArrow f a g       = IArrow (second f) (second a) (h *** g)+  IArrow f a g *** IArr h       = IArrow (first f) (first a) (g *** h)+  IArrow f a g *** IArrow h b i = IArrow (f *** h) (a *** b) (g *** i)+  {-# INLINABLE (***) #-}++  IArr f &&& IArr g = IArr (f &&& g)+  IArrow f a g &&& IArr h = IArrow (f &&& h) (first a) (first g)+  IArr h &&& IArrow f a g = IArrow (h &&& f) (second a) (second g)+  -- TODO: use a rule to use a &&& b instead when f == h+  IArrow f a g &&& IArrow h b i = IArrow (f &&& h) (a *** b) (g *** i)+  {-# INLINABLE (&&&) #-}++instance (ArrowZero a) => ArrowZero (ImproveArrow a) where+  zeroArrow = lift zeroArrow+  {-# INLINE zeroArrow #-}++instance (ArrowPlus a) => ArrowPlus (ImproveArrow a) where+  f <+> g = lift (lowerImprove f <+> lowerImprove g)+  {-# INLINE (<+>) #-}++instance (ArrowChoice a) => ArrowChoice (ImproveArrow a) where+  left (IArr f) = IArr (left f)+  left (IArrow f a g) = IArrow (left f) (left a) (left g)+  {-# INLINE left #-}++  right (IArr f) = IArr (right f)+  right (IArrow f a g) = IArrow (right f) (right a) (right g)+  {-# INLINE right #-}++  IArr f +++ IArr g = IArr (f +++ g)+  IArrow f a g +++ IArr h = IArrow (left f) (left a) (g +++ h)+  IArr h +++ IArrow f a g = IArrow (right f) (right a) (h +++ g)+  IArrow f a g +++ IArrow h b i = IArrow (f +++ h) (a +++ b) (g +++ i)+  {-# INLINABLE (+++) #-}++  IArr f ||| IArr g = IArr (f ||| g)+  IArrow f a g ||| IArr h = IArrow (left f) (left a) (g ||| h)+  IArr h ||| IArrow f a g = IArrow (right f) (right a) (h ||| g)+  -- TODO: use rules to turn the +++ into a ||| on the arrow when g == i+  IArrow f a g ||| IArrow h b i = IArrow (f +++ h) (a +++ b) (g ||| i)+  {-# INLINABLE (|||) #-}++instance (ArrowApply a) => ArrowApply (ImproveArrow a) where+  app = lift $ first lowerImprove ^>> app+  {-# INLINE app #-}++instance (ArrowLoop a) => ArrowLoop (ImproveArrow a) where+  loop (IArr f)        = IArr f'+    where f' x         = let (y, k) = f (x, k) in y+  loop (IArrow f a g)  = lift (loop (f ^>> a >>^ g))+  {-# INLINE loop #-}++instance (ArrowCircuit a) => ArrowCircuit (ImproveArrow a) where+  delay = lift . delay+  {-# INLINE delay #-}++instance (ArrowState s a) => ArrowState s (ImproveArrow a) where+  fetch = lift fetch+  {-# INLINE fetch #-}+  store = lift store+  {-# INLINE store #-}++instance (ArrowReader r a) => ArrowReader r (ImproveArrow a) where+  readState = lift readState+  {-# INLINE readState #-}+  newReader (IArr f) = lift $ newReader $ arr f+  newReader (IArrow f a g) = IArrow id (newReader (f ^>> a)) g+  {-# INLINE newReader #-}++instance (Monoid w, ArrowWriter w a) => ArrowWriter w (ImproveArrow a) where+  write = lift write+  {-# INLINE write #-}+  newWriter (IArr f)       = IArr ((\x -> (x, mempty)) . f)+  newWriter (IArrow f a g) = IArrow f (newWriter (a >>^ g)) id+  {-# INLINABLE newWriter #-}++instance (ArrowError ex a) => ArrowError ex (ImproveArrow a) where+  raise = lift raise+  {-# INLINE raise #-}++  handle (IArr f) _       = IArr f+  handle a@(IArrow _ _ _) e = lift (handle (lowerImprove a) (lowerImprove e))+  {-# INLINABLE handle #-}++  tryInUnless (IArr g) f _   = IArr (\x -> (x, g x)) >>> f+  tryInUnless a@(IArrow _ _ _) f e = lift (tryInUnless (lowerImprove a)+                                                         (lowerImprove f)+                                                         (lowerImprove e))+  {-# INLINABLE tryInUnless #-}++  newError (IArr f) = IArr (Right . f)+  newError a@(IArrow _ _ _) = lift (newError (lowerImprove a))+  {-# INLINABLE newError #-}++instance (Arrow a) => Functor (ImproveArrow a b) where+  fmap f = (>>^ f)+  {-# INLINE fmap #-}++instance (Arrow a) => Applicative (ImproveArrow a b) where+  pure k = IArr (\_ -> k)+  {-# INLINE pure #-}+  f <*> x = (f &&& x) >>^ uncurry id+  {-# INLINE (<*>) #-}++instance (ArrowPlus a) => Alternative (ImproveArrow a b) where+  empty = zeroArrow+  {-# INLINE empty #-}+  (<|>) = (<+>)+  {-# INLINE (<|>) #-}++instance (ArrowApply a) => Monad (ImproveArrow a b) where+  return = pure+  {-# INLINE return #-}+  x >>= f = ((x >>^ f) &&& id) >>> app+  {-# INLINE (>>=) #-}++instance (ArrowPlus a, ArrowApply a) => MonadPlus (ImproveArrow a b) where+  mzero = zeroArrow+  {-# INLINE mzero #-}+  mplus = (<+>)+  {-# INLINE mplus #-}++instance (ArrowApply a) => MonadZip (ImproveArrow a b) where+  mzip = (&&&)+  {-# INLINE mzip #-}++instance (Arrow a) => Profunctor (ImproveArrow a) where+  dimap f g x = f ^>> x >>^ g+  {-# INLINE dimap #-}+  lmap f x = f ^>> x+  {-# INLINE lmap #-}+  rmap g x = x >>^ g+  {-# INLINE rmap #-}++instance (Arrow a) => Strong (ImproveArrow a) where+  first' = first+  {-# INLINE first' #-}+  second' = second+  {-# INLINE second' #-}++instance (ArrowChoice a) => Choice (ImproveArrow a) where+  left' = left+  {-# INLINE left' #-}+  right' = right+  {-# INLINE right' #-}++instance (Arrow a) => Pointed (ImproveArrow a b) where+  point = pure+  {-# INLINE point #-}++instance (Arrow a) => Semigroupoid (ImproveArrow a) where+  o = (.)+  {-# INLINE o #-}++instance (ArrowPlus a) => Alt (ImproveArrow a b) where+  (<!>) = (<+>)+  {-# INLINE (<!>) #-}++instance (Arrow a) => Apply (ImproveArrow a b) where+  (<.>) = (<*>)+  {-# INLINE (<.>) #-}++instance (ArrowApply a) => Bind (ImproveArrow a b) where+  (>>-) = (>>=)+  {-# INLINE (>>-) #-}++instance (ArrowPlus a) => Plus (ImproveArrow a b) where+  zero = zeroArrow+  {-# INLINE zero #-}++instance (ArrowPlus a) => Monoid (ImproveArrow a b c) where+  mempty = zeroArrow+  {-# INLINE mempty #-}+  mappend = (<+>)+  {-# INLINE mappend #-}++instance (Arrow a, Num c) => Num (ImproveArrow a b c) where+  (+) = liftA2 (+)+  {-# INLINE (+) #-}+  (-) = liftA2 (-)+  {-# INLINE (-) #-}+  (*) = liftA2 (*)+  {-# INLINE (*) #-}++  negate = fmap negate+  {-# INLINE negate #-}++  abs = fmap abs+  {-# INLINE abs #-}+  signum = fmap signum+  {-# INLINE signum #-}++  fromInteger = pure . fromInteger+  {-# INLINE fromInteger #-}++instance (Arrow a, Fractional c) => Fractional (ImproveArrow a b c) where+  (/) = liftA2 (/)+  {-# INLINE (/) #-}++  recip = fmap recip+  {-# INLINE recip #-}++  fromRational = pure . fromRational+  {-# INLINE fromRational #-}++instance (Arrow a, Floating c) => Floating (ImproveArrow a b c) where+  pi = pure pi+  {-# INLINE pi #-}++  exp = fmap exp+  {-# INLINE exp #-}+  log = fmap log+  {-# INLINE log #-}+  sqrt = fmap sqrt+  {-# INLINE sqrt #-}++  (**) = liftA2 (**)+  {-# INLINE (**) #-}+  logBase = liftA2 logBase+  {-# INLINE logBase #-}++  sin = fmap sin+  {-# INLINE sin #-}+  cos = fmap cos+  {-# INLINE cos #-}+  tan = fmap tan+  {-# INLINE tan #-}++  asin = fmap asin+  {-# INLINE asin #-}+  acos = fmap acos+  {-# INLINE acos #-}+  atan = fmap atan+  {-# INLINE atan #-}++  sinh = fmap sinh+  {-# INLINE sinh #-}+  cosh = fmap cosh+  {-# INLINE cosh #-}+  tanh = fmap tanh+  {-# INLINE tanh #-}++  asinh = fmap asinh+  {-# INLINE asinh #-}+  acosh = fmap acosh+  {-# INLINE acosh #-}+  atanh = fmap atanh+  {-# INLINE atanh #-}++instance (Arrow a, IsString c) => IsString (ImproveArrow a b c) where+  fromString = pure . fromString+  {-# INLINE fromString #-}++instance (Arrow a) => ArrowTransformer ImproveArrow a where+  lift x = IArrow id x id+  {-# INLINE lift #-}+

+ LICENSE view

@@ -0,0 +1,20 @@+Copyright (C) 2014 Alistair Lynn++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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ arrow-improve.cabal view

@@ -0,0 +1,24 @@+name:                arrow-improve+version:             0.1.0.0+synopsis:            Improved arrows.+description:+  Optimisations to arrows.+homepage:            https://github.com/prophile/arrow-improve/+license:             MIT+license-file:        LICENSE+author:              Alistair Lynn+maintainer:          arplynn@gmail.com+copyright:           © Alistair Lynn, 2014+category:            Control+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Control.Arrow.Improve+  build-depends:+    base >=4.6 && <4.7,+    arrows >= 0.4.4 && <0.5,+    profunctors >= 3.2 && <5,+    pointed <5,+    semigroupoids == 4.*+  default-language:    Haskell2010