diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ + +## 0.1.0.0 + +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Dennis Gosnell (c) 2017-2018 + +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 Author name here 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ + +Data.WorldPeace +========================== + +[![Build Status](https://secure.travis-ci.org/cdepillabout/world-peace.svg)](http://travis-ci.org/cdepillabout/world-peace) +[![Hackage](https://img.shields.io/hackage/v/world-peace.svg)](https://hackage.haskell.org/package/world-peace) +[![Stackage LTS](http://stackage.org/package/world-peace/badge/lts)](http://stackage.org/lts/package/world-peace) +[![Stackage Nightly](http://stackage.org/package/world-peace/badge/nightly)](http://stackage.org/nightly/package/world-peace) +![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg) + +This package defines open union and open product types. It also defines many +combinators for working with these types. + +See the [hackage documentation](https://hackage.haskell.org/package/world-peace) +for more explanation and examples. 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/src/Data/WorldPeace.hs b/src/Data/WorldPeace.hs new file mode 100644 --- /dev/null +++ b/src/Data/WorldPeace.hs @@ -0,0 +1,84 @@ +{- | +Module : Data.WorldPeace + +Copyright : Dennis Gosnell 2017 +License : BSD3 + +Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) +Stability : experimental +Portability : unknown + +This package defines a type called 'OpenUnion'. This represents an open union +of possible types (also called an open sum type). + +Here is an example of taking a 'String', and lifting it up into an open union +of a 'String' and 'Int': + +@ + let int = 3 :: 'Int' + let o = 'openUnionLift' int :: 'OpenUnion' \'['String', 'Int'] +@ + +There are a couple different ways to pattern match on a 'OpenUnion'. + +The easiest one is to use 'catchesOpenUnion', which takes a tuple of handlers for +each possible type in the 'OpenUnion': + +@ + let strHandler = (\str -> \"got a String: \" '++' str) :: 'String' -> 'String' + intHandler = (\int -> \"got an Int: \" '++' 'show' int) :: 'Int' -> 'String' + in 'catchesOpenUnion' (strHandler, intHandler) u :: 'String' +@ + +The above will print @got an Int: 3@. + +There is also the 'openUnionMatch' function, as well as 'fromOpenUnion' and +'openUnion'. Read the documentation below for more information. +-} + +module Data.WorldPeace + ( + -- * 'OpenUnion' + OpenUnion + -- ** 'OpenUnion' Helpers + , openUnion + , fromOpenUnion + , fromOpenUnionOr + , openUnionPrism + , openUnionLift + , openUnionMatch + , catchesOpenUnion + , IsMember + -- ** 'Union' (used by 'OpenUnion') + -- | 'OpenUnion' is a type synonym around 'Union'. Most users will be able to + -- work directly with 'OpenUnion' and ignore this 'Union' type. + , Union(..) + -- *** Union helpers + , union + , absurdUnion + , umap + , catchesUnion + -- *** Union optics + , _This + , _That + -- *** Typeclasses used with Union + , Nat(Z, S) + , RIndex + , UElem(..) + -- ** 'OpenProduct' + -- | This 'OpenProduct' type is used to easily create a case-analysis for + -- 'Union's. You can see it being used in 'catchesOpenUnion' and + -- The 'ToProduct' type class makes it easy to convert a + -- tuple to a 'Product'. This class is used so that the end user only has to worry + -- about working with tuples, and can mostly ignore this 'Product' type. + , OpenProduct + , Product(..) + , ToOpenProduct + , tupleToOpenProduct + , ToProduct + , tupleToProduct + , ReturnX + ) where + +import Data.WorldPeace.Product +import Data.WorldPeace.Union diff --git a/src/Data/WorldPeace/Internal.hs b/src/Data/WorldPeace/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/WorldPeace/Internal.hs @@ -0,0 +1,6 @@ + +module Data.WorldPeace.Internal + ( module X + ) where + +import Data.WorldPeace.Internal.Prism as X diff --git a/src/Data/WorldPeace/Internal/Prism.hs b/src/Data/WorldPeace/Internal/Prism.hs new file mode 100644 --- /dev/null +++ b/src/Data/WorldPeace/Internal/Prism.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE RankNTypes #-} + +{- | +Module : Data.WorldPeace.Internal.Prism +License : BSD3 +Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) +Stability : experimental +Portability : unknown + +These functions are for working with Optics popularized by the + package. Documentation can be +found in the lens package. These functions are redefined here to remove the +dependency on the lens package. +-} + +module Data.WorldPeace.Internal.Prism + ( Prism + , prism + , Prism' + , prism' + , Iso + , iso + , review + , preview + , (<>~) + ) where + +import Data.Profunctor.Unsafe((#.)) +import Control.Applicative +import Data.Coerce +import Data.Functor.Identity +import Data.Monoid +import Data.Profunctor +import Data.Tagged + +type Iso s t a b + = forall p f. (Profunctor p, Functor f) => + p a (f b) -> p s (f t) + +type Prism s t a b + = forall p f. (Choice p, Applicative f) => + p a (f b) -> p s (f t) + +type Prism' s a = Prism s s a a + +type ASetter s t a b = (a -> Identity b) -> s -> Identity t + +iso :: (s -> a) -> (b -> t) -> Iso s t a b +iso sa bt = dimap sa (fmap bt) +{-# INLINE iso #-} + +prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b +prism bt seta = dimap seta (either pure (fmap bt)) . right' +{-# INLINE prism #-} + +prism' :: (a -> s) -> (s -> Maybe a) -> Prism' s a +prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s)) +{-# INLINE prism' #-} + +review :: Prism' t b -> b -> t +review p = coerce . p . Tagged . Identity +{-# INLINE review #-} + +preview :: Prism' s a -> s -> Maybe a +preview l = coerce . l (Const . First . Just) +{-# INLINE preview #-} + +over :: ASetter s t a b -> (a -> b) -> s -> t +over l f = runIdentity #. l (Identity #. f) +{-# INLINE over #-} + +infixr 4 <>~ +(<>~) :: Monoid a => ASetter s t a a -> a -> s -> t +l <>~ n = over l (`mappend` n) +{-# INLINE (<>~) #-} diff --git a/src/Data/WorldPeace/Product.hs b/src/Data/WorldPeace/Product.hs new file mode 100644 --- /dev/null +++ b/src/Data/WorldPeace/Product.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Module : Data.WorldPeace.Product + +Copyright : Dennis Gosnell 2017 +License : BSD3 + +Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) +Stability : experimental +Portability : unknown + +This module defines an open product type. This is used in the case-analysis +handler for the open sum type ('Data.WorldPeace.Union.catchesUnion'). +-} + +module Data.WorldPeace.Product + where + +import Data.Functor.Identity (Identity(Identity)) + +-- $setup +-- >>> -- :set -XDataKinds + +------------- +-- Product -- +------------- + +-- | An extensible product type. This is similar to +-- 'Data.WorldPeace.Union.Union', except a product type +-- instead of a sum type. +data Product (f :: u -> *) (as :: [u]) where + Nil :: Product f '[] + Cons :: !(f a) -> Product f as -> Product f (a ': as) + +-- | This type class provides a way to turn a tuple into a 'Product'. +class ToProduct (tuple :: *) (f :: u -> *) (as :: [u]) | f as -> tuple where + -- | Convert a tuple into a 'Product'. See 'tupleToProduct' for examples. + toProduct :: tuple -> Product f as + +-- | Convert a single value into a 'Product'. +instance forall (f :: u -> *) (a :: u). ToProduct (f a) f '[a] where + toProduct :: f a -> Product f '[a] + toProduct fa = Cons fa Nil + +-- | Convert a tuple into a 'Product'. +instance forall (f :: u -> *) (a :: u) (b :: u). ToProduct (f a, f b) f '[a, b] where + toProduct :: (f a, f b) -> Product f '[a, b] + toProduct (fa, fb) = Cons fa $ Cons fb Nil + +-- | Convert a 3-tuple into a 'Product'. +instance forall (f :: u -> *) (a :: u) (b :: u) (c :: u). ToProduct (f a, f b, f c) f '[a, b, c] where + toProduct :: (f a, f b, f c) -> Product f '[a, b, c] + toProduct (fa, fb, fc) = Cons fa $ Cons fb $ Cons fc Nil + +-- | Convert a 4-tuple into a 'Product'. +instance forall (f :: u -> *) (a :: u) (b :: u) (c :: u) (d :: u). ToProduct (f a, f b, f c, f d) f '[a, b, c, d] where + toProduct :: (f a, f b, f c, f d) -> Product f '[a, b, c, d] + toProduct (fa, fb, fc, fd) = Cons fa $ Cons fb $ Cons fc $ Cons fd Nil + +-- | Turn a tuple into a 'Product'. +-- +-- >>> tupleToProduct (Identity 1, Identity 2.0) :: Product Identity '[Int, Double] +-- Cons (Identity 1) (Cons (Identity 2.0) Nil) +tupleToProduct :: ToProduct t f as => t -> Product f as +tupleToProduct = toProduct + +----------------- +-- OpenProduct -- +----------------- + +-- | @'Product' 'Identity'@ is used as a standard open product type. +type OpenProduct = Product Identity + +-- | 'ToOpenProduct' gives us a way to convert a tuple to an 'OpenProduct'. +-- See 'tupleToOpenProduct'. +class ToOpenProduct (tuple :: *) (as :: [*]) | as -> tuple where + toOpenProduct :: tuple -> OpenProduct as + +-- | Convert a single value into an 'OpenProduct'. +instance forall (a :: *). ToOpenProduct a '[a] where + toOpenProduct :: a -> OpenProduct '[a] + toOpenProduct a = Cons (Identity a) Nil + +-- | Convert a tuple into an 'OpenProduct'. +instance + forall (a :: *) (b :: *). ToOpenProduct (a, b) '[a, b] where + toOpenProduct :: (a, b) -> OpenProduct '[a, b] + toOpenProduct (a, b) = Cons (Identity a) $ Cons (Identity b) Nil + +-- | Convert a 3-tuple into an 'OpenProduct'. +instance + forall (a :: *) (b :: *) (c :: *). ToOpenProduct (a, b, c) '[a, b, c] where + toOpenProduct :: (a, b, c) -> OpenProduct '[a, b, c] + toOpenProduct (a, b, c) = + Cons (Identity a) $ Cons (Identity b) $ Cons (Identity c) Nil + +-- | Convert a 4-tuple into an 'OpenProduct'. +instance + forall (a :: *) (b :: *) (c :: *) (d :: *). + ToOpenProduct (a, b, c, d) '[a, b, c, d] where + toOpenProduct :: (a, b, c, d) -> OpenProduct '[a, b, c, d] + toOpenProduct (a, b, c, d) = + Cons (Identity a) + . Cons (Identity b) + . Cons (Identity c) + $ Cons (Identity d) Nil + +-- | Turn a tuple into an 'OpenProduct'. +-- +-- ==== __Examples__ +-- +-- Turn a triple into an 'OpenProduct': +-- +-- >>> tupleToOpenProduct (1, 2.0, "hello") :: OpenProduct '[Int, Double, String] +-- Cons (Identity 1) (Cons (Identity 2.0) (Cons (Identity "hello") Nil)) +-- +-- Turn a single value into an 'OpenProduct': +-- +-- >>> tupleToOpenProduct 'c' :: OpenProduct '[Char] +-- Cons (Identity 'c') Nil +tupleToOpenProduct :: ToOpenProduct t as => t -> OpenProduct as +tupleToOpenProduct = toOpenProduct + +--------------- +-- Instances -- +--------------- + +-- | Show 'Nil' values. +instance Show (Product f '[]) where + show :: Product f '[] -> String + show Nil = "Nil" + +-- | Show 'Cons' values. +instance (Show (f a), Show (Product f as)) => Show (Product f (a ': as)) where + showsPrec :: Int -> (Product f (a ': as)) -> String -> String + showsPrec n (Cons fa prod) = showParen (n > 10) $ + showString "Cons " . showsPrec 11 fa . showString " " . showsPrec 11 prod + diff --git a/src/Data/WorldPeace/Union.hs b/src/Data/WorldPeace/Union.hs new file mode 100644 --- /dev/null +++ b/src/Data/WorldPeace/Union.hs @@ -0,0 +1,622 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Module : Data.WorldPeace.Union + +Copyright : Dennis Gosnell 2017 +License : BSD3 + +Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) +Stability : experimental +Portability : unknown + +This module defines extensible sum-types. This is similar to how + defines extensible records. + +A large portion of the code from this module was taken from the + package. +-} + +module Data.WorldPeace.Union + ( + -- * Union + Union(..) + , union + , catchesUnion + , absurdUnion + , umap + -- ** Optics + , _This + , _That + -- ** Typeclasses + , Nat(Z, S) + , RIndex + , ReturnX + , UElem(..) + , IsMember + -- * OpenUnion + , OpenUnion + , openUnion + , fromOpenUnion + , fromOpenUnionOr + , openUnionPrism + , openUnionLift + , openUnionMatch + , catchesOpenUnion + -- * Setup code for doctests + -- $setup + ) where + +import Control.Applicative ((<|>)) +import Control.DeepSeq (NFData(rnf)) +import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON), Value) +import Data.Aeson.Types (Parser) +import Data.Functor.Identity (Identity(Identity, runIdentity)) +import Data.Typeable (Typeable) +import Text.Read (Read(readPrec), ReadPrec, (<++)) + +import Data.WorldPeace.Internal.Prism + ( Prism + , Prism' + , iso + , preview + , prism + , prism' + , review + ) +import Data.WorldPeace.Product + ( Product(Cons, Nil) + , ToOpenProduct + , ToProduct + , tupleToOpenProduct + , tupleToProduct + ) + +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XGADTs +-- >>> :set -XTypeOperators +-- >>> import Data.Text (Text) +-- >>> import Text.Read (readMaybe) + +------------------------ +-- Type-level helpers -- +------------------------ + +-- | A partial relation that gives the index of a value in a list. +-- +-- ==== __Examples__ +-- +-- Find the first item: +-- +-- >>> import Data.Type.Equality ((:~:)(Refl)) +-- >>> Refl :: RIndex String '[String, Int] :~: 'Z +-- Refl +-- +-- Find the third item: +-- +-- >>> Refl :: RIndex Char '[String, Int, Char] :~: 'S ('S 'Z) +-- Refl +type family RIndex (r :: k) (rs :: [k]) :: Nat where + RIndex r (r ': rs) = 'Z + RIndex r (s ': rs) = 'S (RIndex r rs) + +-- | Change a list of types into a list of functions that take the given type +-- and return @x@. +-- +-- >>> import Data.Type.Equality ((:~:)(Refl)) +-- >>> Refl :: ReturnX Double '[String, Int] :~: '[String -> Double, Int -> Double] +-- Refl +-- +-- Don't do anything with an empty list: +-- +-- >>> Refl :: ReturnX Double '[] :~: '[] +-- Refl +type family ReturnX x as where + ReturnX x (a ': as) = ((a -> x) ': ReturnX x as) + ReturnX x '[] = '[] + +-- | A mere approximation of the natural numbers. And their image as lifted by +-- @-XDataKinds@ corresponds to the actual natural numbers. +data Nat = Z | S !Nat + +----------------------------- +-- Union (from Data.Union) -- +----------------------------- + +-- | A 'Union' is parameterized by a universe @u@, an interpretation @f@ +-- and a list of labels @as@. The labels of the union are given by +-- inhabitants of the kind @u@; the type of values at any label @a :: +-- u@ is given by its interpretation @f a :: *@. +-- +-- What does this mean in practice? It means that a type like +-- @'Union' 'Identity' \'['String', 'Int']@ can be _either_ an +-- @'Identity' 'String'@ or an @'Identity' 'Int'@. +-- +-- You need to pattern match on the 'This' and 'That' constructors to figure +-- out whether you are holding a 'String' or 'Int': +-- +-- >>> let u = That (This (Identity 1)) :: Union Identity '[String, Int] +-- >>> :{ +-- case u of +-- This (Identity str) -> "we got a string: " ++ str +-- That (This (Identity int)) -> "we got an int: " ++ show int +-- :} +-- "we got an int: 1" +-- +-- There are multiple functions that let you perform this pattern matching +-- easier: 'union', 'catchesUnion', 'unionMatch' +-- +-- There is also a type synonym 'OpenUnion' for the common case of +-- @'Union' 'Indentity'@, as well as helper functions for working with it. +data Union (f :: u -> *) (as :: [u]) where + This :: !(f a) -> Union f (a ': as) + That :: !(Union f as) -> Union f (a ': as) + deriving (Typeable) + +-- | Case analysis for 'Union'. +-- +-- ==== __Examples__ +-- +-- Here is an example of matching on a 'This': +-- +-- >>> let u = This (Identity "hello") :: Union Identity '[String, Int] +-- >>> let runIdent = runIdentity :: Identity String -> String +-- >>> union (const "not a String") runIdent u +-- "hello" +-- +-- Here is an example of matching on a 'That': +-- +-- >>> let v = That (This (Identity 3.3)) :: Union Identity '[String, Double, Int] +-- >>> union (const "not a String") runIdent v +-- "not a String" +union :: (Union f as -> c) -> (f a -> c) -> Union f (a ': as) -> c +union _ onThis (This a) = onThis a +union onThat _ (That u) = onThat u + +-- | Since a union with an empty list of labels is uninhabited, we +-- can recover any type from it. +absurdUnion :: Union f '[] -> a +absurdUnion u = case u of {} + +-- | Map over the interpretation @f@ in the 'Union'. +-- +-- ==== __Examples__ +-- +-- Here is an example of changing a @'Union' 'Identity' \'['String', 'Int']@ to +-- @'Union' 'Maybe' \'['String', 'Int']@: +-- +-- >>> let u = This (Identity "hello") :: Union Identity '[String, Int] +-- >>> umap (Just . runIdentity) u :: Union Maybe '[String, Int] +-- Just "hello" +umap :: (forall a . f a -> g a) -> Union f as -> Union g as +umap f (This a) = This $ f a +umap f (That u) = That $ umap f u + +catchesUnionProduct + :: forall x f as. + Applicative f + => Product f (ReturnX x as) -> Union f as -> f x +catchesUnionProduct (Cons f _) (This a) = f <*> a +catchesUnionProduct (Cons _ p) (That u) = catchesUnionProduct p u +catchesUnionProduct Nil _ = undefined + +-- | An alternate case anaylsis for a 'Union'. This method uses a tuple +-- containing handlers for each potential value of the 'Union'. This is +-- somewhat similar to the 'Control.Exception.catches' function. +-- +-- ==== __Examples__ +-- +-- Here is an example of handling a 'Union' with two possible values. Notice +-- that a normal tuple is used: +-- +-- >>> let u = This $ Identity 3 :: Union Identity '[Int, String] +-- >>> let intHandler = (Identity $ \int -> show int) :: Identity (Int -> String) +-- >>> let strHandler = (Identity $ \str -> str) :: Identity (String -> String) +-- >>> catchesUnion (intHandler, strHandler) u :: Identity String +-- Identity "3" +-- +-- Given a 'Union' like @'Union' 'Identity' \'['Int', 'String']@, the type of +-- 'catchesUnion' becomes the following: +-- +-- @ +-- 'catchesUnion' +-- :: ('Identity' ('Int' -> 'String'), 'Identity' ('String' -> 'String')) +-- -> 'Union' 'Identity' \'['Int', 'String'] +-- -> 'Identity' 'String' +-- @ +-- +-- Checkout 'catchesOpenUnion' for more examples. +catchesUnion + :: (Applicative f, ToProduct tuple f (ReturnX x as)) + => tuple -> Union f as -> f x +catchesUnion tuple u = catchesUnionProduct (tupleToProduct tuple) u + +-- | Lens-compatible 'Prism' for 'This'. +-- +-- ==== __Examples__ +-- +-- Use '_This' to construct a 'Union': +-- +-- >>> review _This (Just "hello") :: Union Maybe '[String] +-- Just "hello" +-- +-- Use '_This' to try to destruct a 'Union' into a @f a@: +-- +-- >>> let u = This (Identity "hello") :: Union Identity '[String, Int] +-- >>> preview _This u :: Maybe (Identity String) +-- Just (Identity "hello") +-- +-- Use '_This' to try to destruct a 'Union' into a @f a@ (unsuccessfully): +-- +-- >>> let v = That (This (Identity 3.3)) :: Union Identity '[String, Double, Int] +-- >>> preview _This v :: Maybe (Identity String) +-- Nothing +_This :: Prism (Union f (a ': as)) (Union f (b ': as)) (f a) (f b) +_This = prism This (union (Left . That) Right) +{-# INLINE _This #-} + +-- | Lens-compatible 'Prism' for 'That'. +-- +-- ==== __Examples__ +-- +-- Use '_That' to construct a 'Union': +-- +-- >>> let u = This (Just "hello") :: Union Maybe '[String] +-- >>> review _That u :: Union Maybe '[Double, String] +-- Just "hello" +-- +-- Use '_That' to try to peel off a 'That' from a 'Union': +-- +-- >>> let v = That (This (Identity "hello")) :: Union Identity '[Int, String] +-- >>> preview _That v :: Maybe (Union Identity '[String]) +-- Just (Identity "hello") +-- +-- Use '_That' to try to peel off a 'That' from a 'Union' (unsuccessfully): +-- +-- >>> let w = This (Identity 3.5) :: Union Identity '[Double, String] +-- >>> preview _That w :: Maybe (Union Identity '[String]) +-- Nothing +_That :: Prism (Union f (a ': as)) (Union f (a ': bs)) (Union f as) (Union f bs) +_That = prism That (union Right (Left . This)) +{-# INLINE _That #-} + +------------------ +-- type classes -- +------------------ + +-- | @'UElem' a as i@ provides a way to potentially get an @f a@ out of a +-- @'Union' f as@ ('unionMatch'). It also provides a way to create a +-- @'Union' f as@ from an @f a@ ('unionLift'). +-- +-- This is safe because of the 'RIndex' contraint. This 'RIndex' constraint +-- tells us that there /actually is/ an @a@ in @as@ at index @i@. +-- +-- As an end-user, you should never need to implement an additional instance of +-- this typeclass. +class i ~ RIndex a as => UElem (a :: u) (as :: [u]) (i :: Nat) where + {-# MINIMAL unionPrism | unionLift, unionMatch #-} + + -- | This is implemented as @'prism'' 'unionLift' 'unionMatch'@. + unionPrism :: Prism' (Union f as) (f a) + unionPrism = prism' unionLift unionMatch + + -- | This is implemented as @'review' 'unionPrism'@. + unionLift :: f a -> Union f as + unionLift = review unionPrism + + -- | This is implemented as @'preview' 'unionPrism'@. + unionMatch :: Union f as -> Maybe (f a) + unionMatch = preview unionPrism + +instance UElem a (a ': as) 'Z where + unionPrism :: Prism' (Union f (a ': as)) (f a) + unionPrism = _This + {-# INLINE unionPrism #-} + +instance + ( RIndex a (b ': as) ~ ('S i) + , UElem a as i + ) + => UElem a (b ': as) ('S i) where + unionPrism :: Prism' (Union f (b ': as)) (f a) + unionPrism = _That . unionPrism + {-# INLINE unionPrism #-} + +-- | This is a helpful 'Constraint' synonym to assert that @a@ is a member of +-- @as@. You can see how it is used in functions like 'openUnionLift'. +type IsMember (a :: u) (as :: [u]) = UElem a as (RIndex a as) + +--------------- +-- OpenUnion -- +--------------- + +-- | We can use @'Union' 'Identity'@ as a standard open sum type. +type OpenUnion = Union Identity + +-- | Case analysis for 'OpenUnion'. +-- +-- ==== __Examples__ +-- +-- Here is an example of successfully matching: +-- +-- >>> let string = "hello" :: String +-- >>> let o = openUnionLift string :: OpenUnion '[String, Int] +-- >>> openUnion (const "not a String") id o +-- "hello" +-- +-- Here is an example of unsuccessfully matching: +-- +-- >>> let double = 3.3 :: Double +-- >>> let p = openUnionLift double :: OpenUnion '[String, Double, Int] +-- >>> openUnion (const "not a String") id p +-- "not a String" +openUnion + :: (OpenUnion as -> c) -> (a -> c) -> OpenUnion (a ': as) -> c +openUnion onThat onThis = union onThat (onThis . runIdentity) + +-- | This is similar to 'fromMaybe' for an 'OpenUnion'. +-- +-- ==== __Examples__ +-- +-- Here is an example of successfully matching: +-- +-- >>> let string = "hello" :: String +-- >>> let o = openUnionLift string :: OpenUnion '[String, Int] +-- >>> fromOpenUnion (const "not a String") o +-- "hello" +-- +-- Here is an example of unsuccessfully matching: +-- +-- >>> let double = 3.3 :: Double +-- >>> let p = openUnionLift double :: OpenUnion '[String, Double, Int] +-- >>> fromOpenUnion (const "not a String") p +-- "not a String" +fromOpenUnion + :: (OpenUnion as -> a) -> OpenUnion (a ': as) -> a +fromOpenUnion onThat = openUnion onThat id + +-- | Flipped version of 'fromOpenUnion'. +fromOpenUnionOr + :: OpenUnion (a ': as) -> (OpenUnion as -> a) -> a +fromOpenUnionOr = flip fromOpenUnion + +-- | Just like 'unionPrism' but for 'OpenUnion'. +openUnionPrism + :: forall a as. + IsMember a as + => Prism' (OpenUnion as) a +openUnionPrism = unionPrism . iso runIdentity Identity +{-# INLINE openUnionPrism #-} + +-- | Just like 'unionLift' but for 'OpenUnion'. +-- +-- Creating an 'OpenUnion': +-- +-- >>> let string = "hello" :: String +-- >>> openUnionLift string :: OpenUnion '[Double, String, Int] +-- Identity "hello" +openUnionLift + :: forall a as. + IsMember a as + => a -> OpenUnion as +openUnionLift = review openUnionPrism + +-- | Just like 'unionMatch' but for 'OpenUnion'. +-- +-- ==== __Examples__ +-- +-- Successful matching: +-- +-- >>> let string = "hello" :: String +-- >>> let o = openUnionLift string :: OpenUnion '[Double, String, Int] +-- >>> openUnionMatch o :: Maybe String +-- Just "hello" +-- +-- Failure matching: +-- +-- >>> let double = 3.3 :: Double +-- >>> let p = openUnionLift double :: OpenUnion '[Double, String] +-- >>> openUnionMatch p :: Maybe String +-- Nothing +openUnionMatch + :: forall a as. + IsMember a as + => OpenUnion as -> Maybe a +openUnionMatch = preview openUnionPrism + +-- | An alternate case anaylsis for an 'OpenUnion'. This method uses a tuple +-- containing handlers for each potential value of the 'OpenUnion'. This is +-- somewhat similar to the 'Control.Exception.catches' function. +-- +-- When working with large 'OpenUnion's, it can be easier to use +-- 'catchesOpenUnion' than 'openUnion'. +-- +-- ==== __Examples__ +-- +-- Here is an example of handling an 'OpenUnion' with two possible values. +-- Notice that a normal tuple is used: +-- +-- >>> let u = openUnionLift (3 :: Int) :: OpenUnion '[Int, String] +-- >>> let intHandler = (\int -> show int) :: Int -> String +-- >>> let strHandler = (\str -> str) :: String -> String +-- >>> catchesOpenUnion (intHandler, strHandler) u :: String +-- "3" +-- +-- Given an 'OpenUnion' like @'OpenUnion' \'['Int', 'String']@, the type of +-- 'catchesOpenUnion' becomes the following: +-- +-- @ +-- 'catchesOpenUnion' +-- :: ('Int' -> x, 'String' -> x) +-- -> 'OpenUnion' \'['Int', 'String'] +-- -> x +-- @ +-- +-- Here is an example of handling an 'OpenUnion' with three possible values: +-- +-- >>> let u = openUnionLift ("hello" :: String) :: OpenUnion '[Int, String, Double] +-- >>> let intHandler = (\int -> show int) :: Int -> String +-- >>> let strHandler = (\str -> str) :: String -> String +-- >>> let dblHandler = (\dbl -> "got a double") :: Double -> String +-- >>> catchesOpenUnion (intHandler, strHandler, dblHandler) u :: String +-- "hello" +-- +-- Here is an example of handling an 'OpenUnion' with only one possible value. +-- Notice how a tuple is not used, just a single value: +-- +-- >>> let u = openUnionLift (2.2 :: Double) :: OpenUnion '[Double] +-- >>> let dblHandler = (\dbl -> "got a double") :: Double -> String +-- >>> catchesOpenUnion dblHandler u :: String +-- "got a double" +catchesOpenUnion + :: ToOpenProduct tuple (ReturnX x as) + => tuple -> OpenUnion as -> x +catchesOpenUnion tuple u = + runIdentity $ + catchesUnionProduct (tupleToOpenProduct tuple) u + +--------------- +-- Instances -- +--------------- + +instance NFData (Union f '[]) where + rnf = absurdUnion + +instance (NFData (f a), NFData (Union f as)) => NFData (Union f (a ': as)) where + rnf = union rnf rnf + +instance Show (Union f '[]) where + showsPrec _ = absurdUnion + +instance (Show (f a), Show (Union f as)) => Show (Union f (a ': as)) where + showsPrec n = union (showsPrec n) (showsPrec n) + +-- | This will always fail, since @'Union' f \'[]@ is effectively 'Void'. +instance Read (Union f '[]) where + readsPrec :: Int -> ReadS (Union f '[]) + readsPrec _ _ = [] + +-- | This is only a valid instance when the 'Read' instances for the types +-- don't overlap. +-- +-- For instance, imagine we are working with a 'Union' of a 'String' and a 'Double'. +-- @3.5@ can only be read as a 'Double', not as a 'String'. +-- Oppositely, @\"hello\"@ can only be read as a 'String', not as a 'Double'. +-- +-- >>> let o = readMaybe "Identity 3.5" :: Maybe (Union Identity '[Double, String]) +-- >>> o +-- Just (Identity 3.5) +-- >>> o >>= openUnionMatch :: Maybe Double +-- Just 3.5 +-- >>> o >>= openUnionMatch :: Maybe String +-- Nothing +-- +-- >>> let p = readMaybe "Identity \"hello\"" :: Maybe (Union Identity '[Double, String]) +-- >>> p +-- Just (Identity "hello") +-- >>> p >>= openUnionMatch :: Maybe Double +-- Nothing +-- >>> p >>= openUnionMatch :: Maybe String +-- Just "hello" +-- +-- However, imagine are we working with a 'Union' of a 'String' and +-- 'Data.Text.Text'. @\"hello\"@ can be 'read' as both a 'String' and +-- 'Data.Text.Text'. However, in the following example, it can only be read as +-- a 'String': +-- +-- >>> let q = readMaybe "Identity \"hello\"" :: Maybe (Union Identity '[String, Text]) +-- >>> q +-- Just (Identity "hello") +-- >>> q >>= openUnionMatch :: Maybe String +-- Just "hello" +-- >>> q >>= openUnionMatch :: Maybe Text +-- Nothing +-- +-- If the order of the types is flipped around, we are are able to read @\"hello\"@ +-- as a 'Text' but not as a 'String'. +-- +-- >>> let r = readMaybe "Identity \"hello\"" :: Maybe (Union Identity '[Text, String]) +-- >>> r +-- Just (Identity "hello") +-- >>> r >>= openUnionMatch :: Maybe String +-- Nothing +-- >>> r >>= openUnionMatch :: Maybe Text +-- Just "hello" +instance (Read (f a), Read (Union f as)) => Read (Union f (a ': as)) where + readPrec :: ReadPrec (Union f (a ': as)) + readPrec = fmap This readPrec <++ fmap That readPrec + +instance Eq (Union f '[]) where + (==) = absurdUnion + +instance (Eq (f a), Eq (Union f as)) => Eq (Union f (a ': as)) where + This a1 == This a2 = a1 == a2 + That u1 == That u2 = u1 == u2 + _ == _ = False + +instance Ord (Union f '[]) where + compare = absurdUnion + +instance (Ord (f a), Ord (Union f as)) => Ord (Union f (a ': as)) + where + compare (This a1) (This a2) = compare a1 a2 + compare (That u1) (That u2) = compare u1 u2 + compare (This _) (That _) = LT + compare (That _) (This _) = GT + +instance ToJSON (Union f '[]) where + toJSON :: Union f '[] -> Value + toJSON = absurdUnion + +instance (ToJSON (f a), ToJSON (Union f as)) => ToJSON (Union f (a ': as)) where + toJSON :: Union f (a ': as) -> Value + toJSON = union toJSON toJSON + +-- | This will always fail, since @'Union' f \'[]@ is effectively 'Void'. +instance FromJSON (Union f '[]) where + parseJSON :: Value -> Parser (Union f '[]) + parseJSON _ = fail "Value of Union f '[] can never be created" + +-- | This is only a valid instance when the 'FromJSON' instances for the types +-- don't overlap. +-- +-- This is similar to the 'Read' instance. +instance (FromJSON (f a), FromJSON (Union f as)) => FromJSON (Union f (a ': as)) where + parseJSON :: Value -> Parser (Union f (a ': as)) + parseJSON val = fmap This (parseJSON val) <|> fmap That (parseJSON val) + +-- instance f ~ Identity => Exception (Union f '[]) + +-- instance +-- ( f ~ Identity +-- , Exception a +-- , Typeable as +-- , Exception (Union f as) +-- ) => Exception (Union f (a ': as)) +-- where +-- toException = union toException (toException . runIdentity) +-- fromException sE = matchR <|> matchL +-- where +-- matchR = This . Identity <$> fromException sE +-- matchL = That <$> fromException sE + + + + diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,41 @@ +# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html + +# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) +resolver: nightly-2018-02-26 + +# Local packages, usually specified by relative directory name +packages: +- '.' + +# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true + +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: >= 1.0.0 + +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 + +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] + +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor + +# Enable Hackage-friendly mode, for more details see +# https://docs.haskellstack.org/en/stable/yaml_configuration/#pvp-bounds +# This has been disabled because of the following exchange: +# https://github.com/cdepillabout/pretty-simple/pull/1#issuecomment-272706215 +#pvp-bounds: both diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -0,0 +1,40 @@ + +module Main (main) where + +import Prelude + +import Data.Monoid ((<>)) +import System.FilePath.Glob (glob) +import Test.DocTest (doctest) + +main :: IO () +main = glob "src/**/*.hs" >>= doDocTest + +doDocTest :: [String] -> IO () +doDocTest options = doctest $ options <> ghcExtensions + +ghcExtensions :: [String] +ghcExtensions = + [ + -- "-XConstraintKinds" + -- , "-XDataKinds" + "-XDeriveDataTypeable" + , "-XDeriveGeneric" + -- , "-XEmptyDataDecls" + , "-XFlexibleContexts" + -- , "-XFlexibleInstances" + -- , "-XGADTs" + -- , "-XGeneralizedNewtypeDeriving" + -- , "-XInstanceSigs" + -- , "-XMultiParamTypeClasses" + -- , "-XNoImplicitPrelude" + , "-XOverloadedStrings" + -- , "-XPolyKinds" + -- , "-XRankNTypes" + -- , "-XRecordWildCards" + , "-XScopedTypeVariables" + -- , "-XStandaloneDeriving" + -- , "-XTupleSections" + -- , "-XTypeFamilies" + -- , "-XTypeOperators" + ] diff --git a/world-peace.cabal b/world-peace.cabal new file mode 100644 --- /dev/null +++ b/world-peace.cabal @@ -0,0 +1,47 @@ +name: world-peace +version: 0.1.0.0 +synopsis: Open Union and Open Product Types +description: Please see . +homepage: https://github.com/cdepillabout/world-peace +license: BSD3 +license-file: LICENSE +author: Dennis Gosnell +maintainer: cdep.illabout@gmail.com +copyright: 2017-2018 Dennis Gosnell +category: Data +build-type: Simple +extra-source-files: CHANGELOG.md + , README.md + , stack.yaml +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Data.WorldPeace + , Data.WorldPeace.Internal + , Data.WorldPeace.Internal.Prism + , Data.WorldPeace.Product + , Data.WorldPeace.Union + build-depends: base >= 4.9 && < 5 + , aeson + , deepseq + , profunctors + , tagged + default-language: Haskell2010 + ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction + other-extensions: QuasiQuotes + , TemplateHaskell + +test-suite world-peace-doctest + type: exitcode-stdio-1.0 + main-is: DocTest.hs + hs-source-dirs: test + build-depends: base + , doctest + , Glob + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + +source-repository head + type: git + location: git@github.com:cdepillabout/world-peace.git