packages feed

world-peace (empty) → 0.1.0.0

raw patch · 12 files changed

+1119/−0 lines, 12 filesdep +Globdep +aesondep +basesetup-changed

Dependencies added: Glob, aeson, base, deepseq, doctest, profunctors, tagged

Files

+ CHANGELOG.md view
@@ -0,0 +1,4 @@++## 0.1.0.0++*   Initial release.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/WorldPeace.hs view
@@ -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
+ src/Data/WorldPeace/Internal.hs view
@@ -0,0 +1,6 @@++module Data.WorldPeace.Internal+  ( module X+  ) where++import Data.WorldPeace.Internal.Prism as X
+ src/Data/WorldPeace/Internal/Prism.hs view
@@ -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+<https://hackage.haskell.org/package/lens lens> 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 (<>~) #-}
+ src/Data/WorldPeace/Product.hs view
@@ -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+
+ src/Data/WorldPeace/Union.hs view
@@ -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+<https://hackage.haskell.org/package/vinyl vinyl> defines extensible records.++A large portion of the code from this module was taken from the+<https://hackage.haskell.org/package/union union> 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++++
+ stack.yaml view
@@ -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
+ test/DocTest.hs view
@@ -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"+    ]
+ world-peace.cabal view
@@ -0,0 +1,47 @@+name:                world-peace+version:             0.1.0.0+synopsis:            Open Union and Open Product Types+description:         Please see <https://github.com/cdepillabout/world-peace#readme README.md>.+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