diff --git a/Control/Newtype.hs b/Control/Newtype.hs new file mode 100644 --- /dev/null +++ b/Control/Newtype.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{- | +The 'Newtype' typeclass and related functions: 'op', 'ala', 'ala'', 'under'. +Primarly pulled from Conor McBride's Epigram work. Some examples: + +@ala Sum foldMap [1,2,3,4] -- foldMaps the list ala the Sum newtype. This results in 10.@ + +@ala Product foldMap [1,2,3,4] -- foldMaps the list ala the Product newtype. This results in 24.@ + +@ala Endo foldMap [(+1), (+2), (subtract 1), (*2)] 3 -- foldMaps the list ala the Endo newtype. This results in 8.@ + +NB: 'Data.Foldable.foldMap' is a generalized @mconcatMap@ which is a generalized @concatMap@. + +This package includes 'Newtype' instances for all the (non-GHC\/foreign) +newtypes in base (as seen in the examples). +However, there are neat things you can do with this with +/any/ newtype and you should definitely define your own 'Newtype' +instances for the power of this library. +For example, see @ala Cont traverse@, with the proper 'Newtype' instance for Cont. + +You can easily define new instances for your newtypes with the help of GHC.Generics + + > {—# LANGUAGE DeriveGeneric #—} + > import GHC.Generics + > + > (...) + > newtype Example = Example Int {deriving Generic) + > + > instance Newtype Example + > + +This avoids the use of Template Haskell (TH) to get new instances. +-} +module Control.Newtype + ( Newtype(..) + , op + , ala + , ala' + , under + , over + , underF + , overF + ) where + +import Data.Monoid +import Control.Applicative +import Control.Arrow +import GHC.Generics + +-- | Given a newtype @n@, we will always have the same unwrapped type @o@, +-- meaning we can represent this with a fundep @n -> o@. +-- +-- Any instance of this class just needs to let @pack@ equal to the newtype's +-- constructor, and let @unpack@ destruct the newtype with pattern matching. +{-class Newtype n o | n -> o where-} + {-pack :: o -> n-} + {-unpack :: n -> o-} + + +-- Generic Newtype +class GNewtype n where + type GO n :: * + gpack :: GO n -> n p + gunpack :: n p -> GO n + +-- We only need one instance, if these generic functions are only to work for +-- newtypes, as these have a fixed form. For example, for a newtype X = Y, +-- Rep X = D1 ... (C1 ... (S1 ... (K1 ... Y))) +instance GNewtype (D1 d (C1 c (S1 s (K1 i a)))) where + type GO (D1 d (C1 c (S1 s (K1 i a)))) = a + gpack x = M1 (M1 (M1 (K1 x))) + gunpack (M1 (M1 (M1 (K1 x)))) = x + +-- Original Newtype class, extended with generic defaults (trivial) and deprived +-- of the second type argument (less trivial, as it involves a type family with +-- a default, plus an equality constraint for the related type family in +-- GNewtype). We do get rid of MultiParamTypeClasses and FunctionalDependencies, +-- though. + +-- | As long as the type @n@ is an instance of Generic, you can create an instance +-- with just @instance Newtype n@ +class Newtype n where + type O n :: * + type O n = GO (Rep n) + + pack :: O n -> n + default pack :: (Generic n, GNewtype (Rep n), O n ~ GO (Rep n)) => O n -> n + pack = to . gpack + + unpack :: n -> O n + default unpack :: (Generic n, GNewtype (Rep n), O n ~ GO (Rep n)) => n -> O n + unpack = gunpack . from + +-- | +-- This function serves two purposes: +-- +-- 1. Giving you the unpack of a newtype without you needing to remember the name. +-- +-- 2. Showing that the first parameter is /completely ignored/ on the value level, +-- meaning the only reason you pass in the constructor is to provide type +-- information. Typeclasses sure are neat. +op :: (Newtype n,o ~ O n ) => (o -> n) -> n -> o +op _ = unpack + +-- | The workhorse of the package. Given a pack and a \"higher order function\", +-- it handles the packing and unpacking, and just sends you back a regular old +-- function, with the type varying based on the hof you passed. +-- +-- The reason for the signature of the hof is due to 'ala' not caring about structure. +-- To illustrate why this is important, another function in this package is 'under'. +-- It is not extremely useful; @under2@ might be more useful (with e.g., @mappend@), +-- but then we already digging the trench of +-- \"What about @under3@? @under4@?\". +-- The solution utilized here is to just hand off the \"packer\" to the hof. +-- That way your structure can be imposed in the hof, +-- whatever you may want it to be (e.g., List, Traversable). +ala :: (Newtype n, Newtype n', o' ~ O n', o ~ O n) + => (o -> n) -> ((o -> n) -> b -> n') -> (b -> o') +ala pa hof = ala' pa hof id + +-- | This is the original function seen in Conor McBride's work. +-- The way it differs from the 'ala' function in this package, +-- is that it provides an extra hook into the \"packer\" passed to the hof. +-- However, this normally ends up being @id@, so 'ala' wraps this function and +-- passes @id@ as the final parameter by default. +-- If you want the convenience of being able to hook right into the hof, +-- you may use this function. +ala' :: (Newtype n, Newtype n', o' ~ O n', o ~ O n) + => (o -> n) -> ((a -> n) -> b -> n') -> (a -> o) -> (b -> o') +ala' _ hof f = unpack . hof (pack . f) + +-- | A very simple operation involving running the function \'under\' the newtype. +-- Suffers from the problems mentioned in the 'ala' function's documentation. +under :: (Newtype n, Newtype n', o' ~ O n', o ~ O n) + => (o -> n) -> (n -> n') -> (o -> o') +under _ f = unpack . f . pack + +-- | The opposite of 'under'. I.e., take a function which works on the +-- underlying types, and switch it to a function that works on the newtypes. +over :: (Newtype n, Newtype n', o' ~ O n', o ~ O n) + => (o -> n) -> (o -> o') -> (n -> n') +over _ f = pack . f . unpack + +-- | 'under' lifted into a Functor. +underF :: (Newtype n, Newtype n', o' ~ O n', o ~ O n, Functor f) + => (o -> n) -> (f n -> f n') -> (f o -> f o') +underF _ f = fmap unpack . f . fmap pack + +-- | 'over' lifted into a Functor. +overF :: (Newtype n, Newtype n', o' ~ O n', o ~ O n, Functor f) + => (o -> n) -> (f o -> f o') -> (f n -> f n') +overF _ f = fmap pack . f . fmap unpack + +instance Newtype All where + type O All = Bool + pack = All + unpack (All x) = x + +instance Newtype Any where + type O Any = Bool + pack = Any + unpack (Any x) = x + +instance Newtype (Sum a) where + type O (Sum a) = a + pack = Sum + unpack (Sum a) = a + +instance Newtype (Product a) where + type O (Product a) = a + pack = Product + unpack (Product a) = a + +instance Newtype (First a) where + type O (First a) = Maybe a + pack = First + unpack (First a) = a + +instance Newtype (Last a) where + type O (Last a) = Maybe a + pack = Last + unpack (Last a) = a + +instance Newtype (Endo a) where + type O (Endo a) = (a -> a) + pack = Endo + unpack (Endo a) = a + +instance Newtype (ZipList a) where + type O (ZipList a) = [a] + pack = ZipList + unpack (ZipList a) = a + +instance Newtype (Const a x) where + type O (Const a x) = a + pack = Const + unpack (Const a) = a + +instance Newtype (Kleisli m a b) where + type O (Kleisli m a b) = a -> m b + pack = Kleisli + unpack (Kleisli a) = a + +instance Newtype (WrappedMonad m a) where + type O (WrappedMonad m a) = m a + pack = WrapMonad + unpack (WrapMonad a) = a + +instance Newtype (WrappedArrow a b c) where + type O (WrappedArrow a b c) = a b c + pack = WrapArrow + unpack (WrapArrow a) = a + +instance Newtype (ArrowMonad a b) where + type O (ArrowMonad a b) = a () b + pack = ArrowMonad + unpack (ArrowMonad a) = a + + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Darius Jahandarie + +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 Darius Jahandarie 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. 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/newtype-generics.cabal b/newtype-generics.cabal new file mode 100644 --- /dev/null +++ b/newtype-generics.cabal @@ -0,0 +1,40 @@ +Name: newtype-generics +Version: 0.4 +Synopsis: A typeclass and set of functions for working with newtypes, with generics support. +Description: Per Conor McBride, the Newtype typeclass represents the packing and unpacking of a newtype, + and allows you to operatate under that newtype with functions such as ala. + + Generics support was added in version 0.4, making this package a full replacement + for the original newtype package, and a better alternative to newtype-th. +License: BSD3 +License-file: LICENSE +Author: Darius Jahandarie, Conor McBride, João Cristovao +Maintainer: João Cristóvão +-- Copyright: +Category: Control +Build-type: Simple +-- Extra-source-files: +Cabal-version: >=1.10 + +Library + Exposed-modules: Control.Newtype + Build-depends: base >= 3.0 && < 5 + -- Other-modules: + -- Build-tools: + Ghc-options: -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/jcristovao/newtype-generics + +test-suite test + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: test,. + build-depends: base >= 4.5 && < 5 + , hspec >= 1.7.2 && < 1.9 + , HUnit >= 1.2.5.2 && < 1.3 + default-language: Haskell2010 + + diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +