diff --git a/Control/Arrow/Improve.hs b/Control/Arrow/Improve.hs
new file mode 100644
--- /dev/null
+++ b/Control/Arrow/Improve.hs
@@ -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 #-}
+
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
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/arrow-improve.cabal b/arrow-improve.cabal
new file mode 100644
--- /dev/null
+++ b/arrow-improve.cabal
@@ -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