Natural transformations

.travis.yml

@@ -0,0 +1,30 @@
+language: haskell
+
+ghc:
+  - 7.0.4
+  - 7.4.2
+  - 7.6.3
+  - 7.8.4
+
+before_install:
+  - export GHCVER=`ghc --numeric-version`
+
+install:
+  - cabal update
+  - |
+    if [ $GHCVER = "7.0.4" ]; then
+      cabal install -j --only-dependencies
+    else
+      cabal install -j --only-dependencies --enable-tests
+    fi
+
+script:
+  - |
+    if [ $GHCVER = "7.0.4" ]; then
+      cabal configure
+      cabal build
+    else
+      cabal configure --enable-tests
+      cabal build
+      cabal test --show-details=always
+    fi

CHANGELOG.md

@@ -0,0 +1,2 @@
+# 0.1
+* Initial commit

LICENSE

@@ -1,24 +1,30 @@
-Copyright (c) 2015, Functional Programming at the University of Kansas
+Copyright (c) 2015, the University of Kansas
+
 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 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.
+    * 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.
 
-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 HOLDER 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.
+    * Neither the name of Andy Gill 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.

README.md

@@ -1,2 +1,3 @@
-# natural-transformation
+# natural-transformation [![Build Status](https://img.shields.io/travis/ku-fpg/kansas-comet.svg?style=flat)](https://travis-ci.org/ku-fpg/kansas-comet)
+
 A natural transformation package

Setup.hs

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

natural-transformation.cabal

@@ -0,0 +1,40 @@
+name:                natural-transformation
+version:             0.1
+synopsis:            A natural transformation package.
+description:         A natural transformation transforms a container @f a@ into another
+                     container @g a@ while preserving the internal structure. Natural
+                     transformations act as functor morphisms in category theory.
+homepage:            https://github.com/ku-fpg/natural-transformation
+bug-reports:         https://github.com/ku-fpg/natural-transformation/issues
+license:             BSD3
+license-file:        LICENSE
+stability:           Experimental
+author:              Andy Gill
+maintainer:          Andy Gill <andygill@ku.edu>
+copyright:           Copyright (c) 2015 The University of Kansas
+category:            Control
+build-type:          Simple
+extra-source-files:  CHANGELOG.md, README.md
+cabal-version:       >=1.8
+
+source-repository head
+  type:                git
+  location:            git://github.com/ku-fpg/natural-transformation
+
+library
+  exposed-modules:     Control.Natural
+  build-depends:       base >= 4 && < 5
+  hs-source-dirs:      src
+  ghc-options:         -Wall
+
+test-suite natural-transformation-properties
+  type:                exitcode-stdio-1.0
+  main-is:             Properties.hs
+  build-depends:       base                   >= 4   && < 5
+                     , containers             >= 0.1 && < 0.6
+                     , natural-transformation == 0.1
+                     , quickcheck-instances   >= 0.1 && < 0.4
+                     , tasty                  >= 0.8 && < 0.11
+                     , tasty-quickcheck       >= 0.8 && < 0.9
+  hs-source-dirs:      tests
+  ghc-options:         -Wall

src/Control/Natural.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, FunctionalDependencies,
+             GADTs, MultiParamTypeClasses, RankNTypes, TypeOperators #-}
+
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706
+# define LANGUAGE_PolyKinds
+{-# LANGUAGE PolyKinds #-}
+#endif
+
+{-|
+Module:      Control.Natural
+Copyright:   (C) 2015 The University of Kansas
+License:     BSD-style (see the file LICENSE)
+Maintainer:  Andy Gill
+Stability:   Experimental
+
+A data type and type class for natural transformations.
+-}
+module Control.Natural
+  ( type (~>)
+  , (:~>)(..)
+  , Transformation(..)
+  ) where
+
+#if defined(LANGUAGE_PolyKinds)
+import qualified Control.Category as C (Category(..))
+#endif
+
+#if !(MIN_VERSION_base(4,8,0))
+import           Data.Monoid (Monoid(..))
+#endif
+import           Data.Typeable (Typeable)
+
+infixr 0 #
+-- | A (natural) transformation is inside @t@, and contains @f@ and @g@
+-- (typically 'Functor's).
+-- 
+-- The order of arguments allows the use of @GeneralizedNewtypeDeriving@ to wrap
+-- a 'Natural', but maintain the 'Transformation' constraint. Thus, '#' can be used
+-- on abstract data types.
+class Transformation f g t | t -> f g where
+    -- | The invocation method for a natural transformation.
+    (#) :: t -> f a -> g a
+
+instance Transformation f g (f :~> g) where
+    Nat f # g = f g
+
+-- Code adapted from Edward Kmett's @indexed@ package
+
+infixr 0 ~>
+-- | A natural transformation from @f@ to @g@.
+type f ~> g = forall x. f x -> g x
+
+infixr 0 :~>, $$
+-- | A data type representing a natural transformation from @f@ to @g@.
+newtype f :~> g = Nat { ($$) :: f ~> g } deriving Typeable
+
+#if defined(LANGUAGE_PolyKinds)
+instance C.Category (:~>) where
+    id = Nat id
+    Nat f . Nat g = Nat (f . g)
+#endif
+
+instance f ~ g => Monoid (f :~> g) where
+    mempty = Nat id
+    mappend (Nat f) (Nat g) = Nat (f . g)

tests/Properties.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE CPP, TypeOperators #-}
+{-|
+Module:      Main
+Copyright:   (C) 2015 The University of Kansas
+License:     BSD-style (see the file LICENSE)
+Maintainer:  Andy Gill
+Stability:   Experimental
+
+@QuickCheck@ properties for natural transformations.
+-}
+module Main (main) where
+
+import Control.Natural ((:~>)(..), Transformation(..))
+
+import Data.Foldable (toList)
+#if !(MIN_VERSION_base(4,8,0))
+import Data.Monoid (Monoid(..))
+#endif
+import Data.Sequence (Seq, fromList)
+
+import Test.QuickCheck.Instances ()
+import Test.Tasty (TestTree, defaultMain, testGroup)
+import Test.Tasty.QuickCheck (Arbitrary, testProperty)
+
+main :: IO ()
+main = defaultMain testProperties
+
+testProperties :: TestTree
+testProperties = testGroup "QuickCheck properties"
+    [ testProperty "Free theorem ([] :~> Seq)" (prop_freeTheorem (+1)    listSeqNT :: [Int] -> Bool)
+    , testProperty "Free theorem (Seq :~> [])" (prop_freeTheorem reverse seqListNT :: Seq String -> Bool)
+    , testProperty "Monoid laws"               (prop_monoidLaws listShiftNT listReverseNT listShiftNT :: [Int] -> Bool)
+    ]
+
+-- | Verifies the free theorem for natural transformations, i.e., that
+-- 
+-- @
+-- fmap h . r == r . fmap h
+-- @
+prop_freeTheorem :: (Arbitrary (f a), Eq (g b), Functor f, Functor g, Transformation f g t)
+                 => (a -> b) -> t -> f a -> Bool
+prop_freeTheorem h r t = fmap h (r # t) == (r # fmap h t)
+
+-- | Verifies that natural transformations form a law-abiding 'Monoid', i.e., that
+-- 
+--  * @mappend mempty x = x@
+--
+--  * @mappend x mempty = x@
+--
+--  * @mappend x (mappend y z) = mappend (mappend x y) z@
+prop_monoidLaws :: (Arbitrary (f a), Eq (f a), Monoid t, Transformation f f t)
+                => t -> t -> t -> f a -> Bool
+prop_monoidLaws x y z t = (mappend mempty x # t) == (x # t)
+                       && (mappend x mempty # t) == (x # t)
+                       && (mappend x (mappend y z) # t)
+                          == (mappend (mappend x y) z # t)
+
+-- | A natural transformations from lists to lists that 'reverse's.
+listReverseNT :: [] :~> []
+listReverseNT = Nat reverse
+
+-- | A natural transformation from lists to lists that shifts all elements to the left,
+-- moving the head element to the back.
+listShiftNT :: [] :~> []
+listShiftNT = Nat $ \l -> case l of
+                               []     -> []
+                               (x:xs) -> xs ++ [x]
+
+-- | A natural transformation from lists to 'Seq's.
+listSeqNT :: [] :~> Seq
+listSeqNT = Nat fromList
+
+-- | A natural transformation from 'Seq's to lists.
+seqListNT :: Seq :~> []
+seqListNT = Nat toList