some-1.0.4.1/0000755000000000000000000000000007346545000011007 5ustar0000000000000000some-1.0.4.1/ChangeLog.md0000644000000000000000000000165507346545000013167 0ustar0000000000000000# 1.0.4.1 - Drop support for GHC before 8.6 # 1.0.4 - Add instances for `(:~~:)` - Add instances for `:+:` and `:*:` - Add `defaultGeq :: GCompare f => f a -> f b -> Maybe (a :~: b)` - Add `defaultGshowsPrec :: Show (t a) => Int -> t a -> ShowS` # 1.0.3 - Make `GNFData` PolyKinded. - Add `GNFData ((:~:) a)` and `GNFData TypeRep` instances # 1.0.2 - Explicitly mark `Data.Some` as `Safe`. It was previously inferred, yet it was Safe too, as it only re-exports other explicitly marked modules. - Allow `base-4.15`, GHC-9.0 compatibility # 1.0.1 - Add 'withSomeM' combinator. Allows to workaround: https://gitlab.haskell.org/ghc/ghc/issues/15681 # 1.0.0.3 - One less `unsafeCoerce` (thanks to David Feuer) # 1.0.0.2 - Broken release # 1.0.0.1 - Fix issue with GHC#9585 https://gitlab.haskell.org/ghc/ghc/issues/9584 # 1 - Split out of `dependent-sum` - Have `GADT`, `Newtype`, `Church` variants - Add `NFData` instance some-1.0.4.1/LICENSE0000644000000000000000000000277507346545000012027 0ustar0000000000000000Copyright (c) 2019 Oleg Grenrus, James Cook 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 Oleg Grenrus 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. some-1.0.4.1/some.cabal0000644000000000000000000000370107346545000012737 0ustar0000000000000000name: some version: 1.0.4.1 cabal-version: >=1.10 build-type: Simple author: James Cook , Oleg Grenrus maintainer: Oleg Grenrus license: BSD3 license-file: LICENSE homepage: https://github.com/haskellari/some category: Data, Dependent Types synopsis: Existential type: Some description: This library defines an existential type 'Some'. . @ data Some f where \ Some :: f a -> Some f @ . in few variants, and utilities to work with it. . If you are unsure which variant to use, use the one in "Data.Some" module. tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.2 || ==9.2.4 || ==9.4.2 extra-source-files: ChangeLog.md flag newtype-unsafe description: Use implementation using @newtype@ and unsafe @Any@, instead of GADT manual: True default: True source-repository head type: git location: git://github.com/haskellari/some.git subdir: some library default-language: Haskell2010 hs-source-dirs: src if flag(newtype-unsafe) cpp-options: -DSOME_NEWTYPE -- main module exposed-modules: Data.Some exposed-modules: Data.GADT.Compare Data.GADT.DeepSeq Data.GADT.Show Data.Some.Church Data.Some.GADT Data.Some.Newtype other-modules: Data.GADT.Internal build-depends: base >=4.12 && <4.18 , deepseq >=1.4.4.0 && <1.5 if impl(ghc >=9.0) -- these flags may abort compilation with GHC-8.10 -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode if impl(ghc >=9.1) ghc-options: -Wmissing-kind-signatures test-suite hkd-example default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: HKD.hs build-depends: base , some some-1.0.4.1/src/Data/GADT/0000755000000000000000000000000007346545000013166 5ustar0000000000000000some-1.0.4.1/src/Data/GADT/Compare.hs0000644000000000000000000000044607346545000015114 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} module Data.GADT.Compare ( -- * Equality GEq (..), defaultGeq, defaultEq, defaultNeq, -- * Total order comparison GCompare (..), defaultCompare, GOrdering (..), ) where import Data.GADT.Internal some-1.0.4.1/src/Data/GADT/DeepSeq.hs0000644000000000000000000000262507346545000015055 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 810 {-# LANGUAGE StandaloneKindSignatures #-} #endif module Data.GADT.DeepSeq ( GNFData (..), ) where import Data.Functor.Product (Product (..)) import Data.Functor.Sum (Sum (..)) import Data.Type.Equality ((:~:) (..), (:~~:) (..)) import GHC.Generics ((:*:) (..), (:+:) (..)) import qualified Type.Reflection as TR #if __GLASGOW_HASKELL__ >= 810 import Data.Kind (Constraint, Type) #endif #if __GLASGOW_HASKELL__ >= 810 type GNFData :: (k -> Type) -> Constraint #endif class GNFData f where grnf :: f a -> () instance (GNFData a, GNFData b) => GNFData (Product a b) where grnf (Pair a b) = grnf a `seq` grnf b instance (GNFData a, GNFData b) => GNFData (Sum a b) where grnf (InL x) = grnf x grnf (InR y) = grnf y instance (GNFData a, GNFData b) => GNFData (a :*: b) where grnf (a :*: b) = grnf a `seq` grnf b instance (GNFData a, GNFData b) => GNFData (a :+: b) where grnf (L1 x) = grnf x grnf (R1 y) = grnf y -- | @since 1.0.3 instance GNFData ((:~:) a) where grnf Refl = () -- | @since 1.0.4 instance GNFData ((:~~:) a) where grnf HRefl = () -- | @since 1.0.3 instance GNFData TR.TypeRep where grnf = TR.rnfTypeRep some-1.0.4.1/src/Data/GADT/Internal.hs0000644000000000000000000004505307346545000015305 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 810 {-# LANGUAGE StandaloneKindSignatures #-} #endif module Data.GADT.Internal where import Control.Applicative (Applicative (..)) import Data.Functor.Product (Product (..)) import Data.Functor.Sum (Sum (..)) import Data.Kind (Type) import Data.Maybe (isJust, isNothing) import Data.Monoid (Monoid (..)) import Data.Semigroup (Semigroup (..)) import Data.Type.Equality (TestEquality (..), (:~:) (..), (:~~:) (..)) import GHC.Generics ((:*:) (..), (:+:) (..)) import qualified Type.Reflection as TR #if __GLASGOW_HASKELL__ >= 810 import Data.Kind (Constraint) #endif -- $setup -- >>> :set -XKindSignatures -XGADTs -XTypeOperators -XStandaloneDeriving -XQuantifiedConstraints -- >>> import Data.Type.Equality -- >>> import Data.Functor.Sum -- >>> import Data.Maybe (isJust, isNothing) -- >>> import GHC.Generics -- |'Show'-like class for 1-type-parameter GADTs. @GShow t => ...@ is equivalent to something -- like @(forall a. Show (t a)) => ...@. The easiest way to create instances would probably be -- to write (or derive) an @instance Show (T a)@, and then simply say: -- -- > instance GShow t where gshowsPrec = defaultGshowsPrec #if __GLASGOW_HASKELL__ >= 810 type GShow :: (k -> Type) -> Constraint #endif class GShow t where gshowsPrec :: Int -> t a -> ShowS -- |If 'f' has a 'Show (f a)' instance, this function makes a suitable default -- implementation of 'gshowsPrec'. -- -- @since 1.0.4 defaultGshowsPrec :: Show (t a) => Int -> t a -> ShowS defaultGshowsPrec = showsPrec gshows :: GShow t => t a -> ShowS gshows = gshowsPrec (-1) gshow :: (GShow t) => t a -> String gshow x = gshows x "" instance GShow ((:~:) a) where gshowsPrec _ Refl = showString "Refl" -- | @since 1.0.4 instance GShow ((:~~:) a) where gshowsPrec _ HRefl = showString "HRefl" instance GShow TR.TypeRep where gshowsPrec = showsPrec -- -- | >>> gshow (InL Refl :: Sum ((:~:) Int) ((:~:) Bool) Int) -- "InL Refl" instance (GShow a, GShow b) => GShow (Sum a b) where gshowsPrec d = \s -> case s of InL x -> showParen (d > 10) (showString "InL " . gshowsPrec 11 x) InR x -> showParen (d > 10) (showString "InR " . gshowsPrec 11 x) -- | >>> gshow (Pair Refl Refl :: Product ((:~:) Int) ((:~:) Int) Int) -- "Pair Refl Refl" instance (GShow a, GShow b) => GShow (Product a b) where gshowsPrec d (Pair x y) = showParen (d > 10) $ showString "Pair " . gshowsPrec 11 x . showChar ' ' . gshowsPrec 11 y -- -- | >>> gshow (L1 Refl :: ((:~:) Int :+: (:~:) Bool) Int) -- "L1 Refl" -- -- @since 1.0.4 instance (GShow a, GShow b) => GShow (a :+: b) where gshowsPrec d = \s -> case s of L1 x -> showParen (d > 10) (showString "L1 " . gshowsPrec 11 x) R1 x -> showParen (d > 10) (showString "R1 " . gshowsPrec 11 x) -- | >>> gshow (Pair Refl Refl :: Product ((:~:) Int) ((:~:) Int) Int) -- "Refl :*: Refl" -- -- @since 1.0.4 instance (GShow a, GShow b) => GShow (a :*: b) where gshowsPrec d (x :*: y) = showParen (d > 6) $ gshowsPrec 6 x . showString " :*: " . gshowsPrec 6 y -- |@GReadS t@ is equivalent to @ReadS (forall b. (forall a. t a -> b) -> b)@, which is -- in turn equivalent to @ReadS (Exists t)@ (with @data Exists t where Exists :: t a -> Exists t@) #if __GLASGOW_HASKELL__ >= 810 type GReadS :: (k -> Type) -> Type #endif type GReadS t = String -> [(Some t, String)] getGReadResult :: Some tag -> (forall a. tag a -> b) -> b getGReadResult t k = withSome t k mkGReadResult :: tag a -> Some tag mkGReadResult = mkSome -- |'Read'-like class for 1-type-parameter GADTs. Unlike 'GShow', this one cannot be -- mechanically derived from a 'Read' instance because 'greadsPrec' must choose the phantom -- type based on the 'String' being parsed. #if __GLASGOW_HASKELL__ >= 810 type GRead :: (k -> Type) -> Constraint #endif class GRead t where greadsPrec :: Int -> GReadS t greads :: GRead t => GReadS t greads = greadsPrec (-1) gread :: GRead t => String -> (forall a. t a -> b) -> b gread s g = withSome (hd [f | (f, "") <- greads s]) g where hd (x:_) = x hd _ = error "gread: no parse" -- | -- -- >>> greadMaybe "InL Refl" mkSome :: Maybe (Some (Sum ((:~:) Int) ((:~:) Bool))) -- Just (mkSome (InL Refl)) -- -- >>> greadMaybe "L1 Refl" mkSome :: Maybe (Some ((:~:) Int :+: (:~:) Bool)) -- Just (mkSome (L1 Refl)) -- -- >>> greadMaybe "garbage" mkSome :: Maybe (Some ((:~:) Int)) -- Nothing -- greadMaybe :: GRead t => String -> (forall a. t a -> b) -> Maybe b greadMaybe s g = case [f | (f, "") <- greads s] of (x : _) -> Just (withSome x g) _ -> Nothing instance GRead ((:~:) a) where greadsPrec _ = readParen False (\s -> [ (S $ \k -> k (Refl :: a :~: a), t) | ("Refl", t) <- lex s ]) -- | @since 1.0.4 instance k1 ~ k2 => GRead ((:~~:) (a :: k1) :: k2 -> Type) where greadsPrec _ = readParen False (\s -> [ (S $ \k -> k (HRefl :: a :~~: a), t) | ("HRefl", t) <- lex s ]) instance (GRead a, GRead b) => GRead (Sum a b) where greadsPrec d s = readParen (d > 10) (\s1 -> [ (S $ \k -> withSome r (k . InL), t) | ("InL", s2) <- lex s1 , (r, t) <- greadsPrec 11 s2 ]) s ++ readParen (d > 10) (\s1 -> [ (S $ \k -> withSome r (k . InR), t) | ("InR", s2) <- lex s1 , (r, t) <- greadsPrec 11 s2 ]) s -- | @since 1.0.4 instance (GRead a, GRead b) => GRead (a :+: b) where greadsPrec d s = readParen (d > 10) (\s1 -> [ (S $ \k -> withSome r (k . L1), t) | ("L1", s2) <- lex s1 , (r, t) <- greadsPrec 11 s2 ]) s ++ readParen (d > 10) (\s1 -> [ (S $ \k -> withSome r (k . R1), t) | ("R1", s2) <- lex s1 , (r, t) <- greadsPrec 11 s2 ]) s ------------------------------------------------------------------------------- -- GEq ------------------------------------------------------------------------------- -- |A class for type-contexts which contain enough information -- to (at least in some cases) decide the equality of types -- occurring within them. -- -- This class is sometimes confused with 'TestEquality' from base. -- 'TestEquality' only checks /type equality/. -- -- Consider -- -- >>> data Tag a where TagInt1 :: Tag Int; TagInt2 :: Tag Int -- -- The correct @'TestEquality' Tag@ instance is -- -- >>> :{ -- instance TestEquality Tag where -- testEquality TagInt1 TagInt1 = Just Refl -- testEquality TagInt1 TagInt2 = Just Refl -- testEquality TagInt2 TagInt1 = Just Refl -- testEquality TagInt2 TagInt2 = Just Refl -- :} -- -- While we can define -- -- @ -- instance 'GEq' Tag where -- 'geq' = 'testEquality' -- @ -- -- this will mean we probably want to have -- -- @ -- instance 'Eq' Tag where -- _ '==' _ = True -- @ -- -- /Note:/ In the future version of @some@ package (to be released around GHC-9.6 / 9.8) the -- @forall a. Eq (f a)@ constraint will be added as a constraint to 'GEq', -- with a law relating 'GEq' and 'Eq': -- -- @ -- 'geq' x y = Just Refl ⇒ x == y = True ∀ (x :: f a) (y :: f b) -- x == y ≡ isJust ('geq' x y) ∀ (x, y :: f a) -- @ -- -- So, the more useful @'GEq' Tag@ instance would differentiate between -- different constructors: -- -- >>> :{ -- instance GEq Tag where -- geq TagInt1 TagInt1 = Just Refl -- geq TagInt1 TagInt2 = Nothing -- geq TagInt2 TagInt1 = Nothing -- geq TagInt2 TagInt2 = Just Refl -- :} -- -- which is consistent with a derived 'Eq' instance for 'Tag' -- -- >>> deriving instance Eq (Tag a) -- -- Note that even if @a ~ b@, the @'geq' (x :: f a) (y :: f b)@ may -- be 'Nothing' (when value terms are inequal). -- -- The consistency of 'GEq' and 'Eq' is easy to check by exhaustion: -- -- >>> let checkFwdGEq :: (forall a. Eq (f a), GEq f) => f a -> f b -> Bool; checkFwdGEq x y = case geq x y of Just Refl -> x == y; Nothing -> True -- >>> (checkFwdGEq TagInt1 TagInt1, checkFwdGEq TagInt1 TagInt2, checkFwdGEq TagInt2 TagInt1, checkFwdGEq TagInt2 TagInt2) -- (True,True,True,True) -- -- >>> let checkBwdGEq :: (Eq (f a), GEq f) => f a -> f a -> Bool; checkBwdGEq x y = if x == y then isJust (geq x y) else isNothing (geq x y) -- >>> (checkBwdGEq TagInt1 TagInt1, checkBwdGEq TagInt1 TagInt2, checkBwdGEq TagInt2 TagInt1, checkBwdGEq TagInt2 TagInt2) -- (True,True,True,True) -- #if __GLASGOW_HASKELL__ >= 810 type GEq :: (k -> Type) -> Constraint #endif class GEq f where -- |Produce a witness of type-equality, if one exists. -- -- A handy idiom for using this would be to pattern-bind in the Maybe monad, eg.: -- -- > extract :: GEq tag => tag a -> DSum tag -> Maybe a -- > extract t1 (t2 :=> x) = do -- > Refl <- geq t1 t2 -- > return x -- -- Or in a list comprehension: -- -- > extractMany :: GEq tag => tag a -> [DSum tag] -> [a] -- > extractMany t1 things = [ x | (t2 :=> x) <- things, Refl <- maybeToList (geq t1 t2)] -- -- (Making use of the 'DSum' type from in both examples) geq :: f a -> f b -> Maybe (a :~: b) -- |If 'f' has a 'GCompare' instance, this function makes a suitable default -- implementation of 'geq'. -- -- @since 1.0.4 defaultGeq :: GCompare f => f a -> f b -> Maybe (a :~: b) defaultGeq a b = case gcompare a b of GEQ -> Just Refl _ -> Nothing -- |If 'f' has a 'GEq' instance, this function makes a suitable default -- implementation of '(==)'. defaultEq :: GEq f => f a -> f b -> Bool defaultEq x y = isJust (geq x y) -- |If 'f' has a 'GEq' instance, this function makes a suitable default -- implementation of '(/=)'. defaultNeq :: GEq f => f a -> f b -> Bool defaultNeq x y = isNothing (geq x y) instance GEq ((:~:) a) where geq (Refl :: a :~: b) (Refl :: a :~: c) = Just (Refl :: b :~: c) -- | @since 1.0.4 instance GEq ((:~~:) a) where geq (HRefl :: a :~~: b) (HRefl :: a :~~: c) = Just (Refl :: b :~: c) instance (GEq a, GEq b) => GEq (Sum a b) where geq (InL x) (InL y) = geq x y geq (InR x) (InR y) = geq x y geq _ _ = Nothing instance (GEq a, GEq b) => GEq (Product a b) where geq (Pair x y) (Pair x' y') = do Refl <- geq x x' Refl <- geq y y' return Refl -- | @since 1.0.4 instance (GEq f, GEq g) => GEq (f :+: g) where geq (L1 x) (L1 y) = geq x y geq (R1 x) (R1 y) = geq x y geq _ _ = Nothing -- | @since 1.0.4 instance (GEq a, GEq b) => GEq (a :*: b) where geq (x :*: y) (x' :*: y') = do Refl <- geq x x' Refl <- geq y y' return Refl instance GEq TR.TypeRep where geq = testEquality ------------------------------------------------------------------------------- -- GCompare ------------------------------------------------------------------------------- -- This instance seems nice, but it's simply not right: -- -- > instance GEq StableName where -- > geq sn1 sn2 -- > | sn1 == unsafeCoerce sn2 -- > = Just (unsafeCoerce Refl) -- > | otherwise = Nothing -- -- Proof: -- -- > x <- makeStableName id :: IO (StableName (Int -> Int)) -- > y <- makeStableName id :: IO (StableName ((Int -> Int) -> Int -> Int)) -- > -- > let Just boom = geq x y -- > let coerce :: (a :~: b) -> a -> b; coerce Refl = id -- > -- > coerce boom (const 0) id 0 -- > let "Illegal Instruction" = "QED." -- -- The core of the problem is that 'makeStableName' only knows the closure -- it is passed to, not any type information. Together with the fact that -- the same closure has the same StableName each time 'makeStableName' is -- called on it, there is serious potential for abuse when a closure can -- be given many incompatible types. -- |A type for the result of comparing GADT constructors; the type parameters -- of the GADT values being compared are included so that in the case where -- they are equal their parameter types can be unified. #if __GLASGOW_HASKELL__ >= 810 type GOrdering :: k -> k -> Type #endif data GOrdering a b where GLT :: GOrdering a b GEQ :: GOrdering t t GGT :: GOrdering a b -- |TODO: Think of a better name -- -- This operation forgets the phantom types of a 'GOrdering' value. weakenOrdering :: GOrdering a b -> Ordering weakenOrdering GLT = LT weakenOrdering GEQ = EQ weakenOrdering GGT = GT instance Eq (GOrdering a b) where x == y = weakenOrdering x == weakenOrdering y instance Ord (GOrdering a b) where compare x y = compare (weakenOrdering x) (weakenOrdering y) instance Show (GOrdering a b) where showsPrec _ GGT = showString "GGT" showsPrec _ GEQ = showString "GEQ" showsPrec _ GLT = showString "GLT" instance GShow (GOrdering a) where gshowsPrec = showsPrec instance GRead (GOrdering a) where greadsPrec _ s = case con of "GGT" -> [(mkSome GGT, rest)] "GEQ" -> [(mkSome GEQ, rest)] "GLT" -> [(mkSome GLT, rest)] _ -> [] where (con, rest) = splitAt 3 s -- |Type class for comparable GADT-like structures. When 2 things are equal, -- must return a witness that their parameter types are equal as well ('GEQ'). #if __GLASGOW_HASKELL__ >= 810 type GCompare :: (k -> Type) -> Constraint #endif class GEq f => GCompare f where gcompare :: f a -> f b -> GOrdering a b instance GCompare ((:~:) a) where gcompare Refl Refl = GEQ -- | @since 1.0.4 instance GCompare ((:~~:) a) where gcompare HRefl HRefl = GEQ instance GCompare TR.TypeRep where gcompare t1 t2 = case testEquality t1 t2 of Just Refl -> GEQ Nothing -> case compare (TR.SomeTypeRep t1) (TR.SomeTypeRep t2) of LT -> GLT GT -> GGT EQ -> error "impossible: 'testEquality' and 'compare' \ \are inconsistent for TypeRep; report this \ \as a GHC bug" defaultCompare :: GCompare f => f a -> f b -> Ordering defaultCompare x y = weakenOrdering (gcompare x y) instance (GCompare a, GCompare b) => GCompare (Sum a b) where gcompare (InL x) (InL y) = gcompare x y gcompare (InL _) (InR _) = GLT gcompare (InR _) (InL _) = GGT gcompare (InR x) (InR y) = gcompare x y instance (GCompare a, GCompare b) => GCompare (Product a b) where gcompare (Pair x y) (Pair x' y') = case gcompare x x' of GLT -> GLT GGT -> GGT GEQ -> case gcompare y y' of GLT -> GLT GEQ -> GEQ GGT -> GGT -- | @since 1.0.4 instance (GCompare f, GCompare g) => GCompare (f :+: g) where gcompare (L1 x) (L1 y) = gcompare x y gcompare (L1 _) (R1 _) = GLT gcompare (R1 _) (L1 _) = GGT gcompare (R1 x) (R1 y) = gcompare x y -- | @since 1.0.4 instance (GCompare a, GCompare b) => GCompare (a :*: b) where gcompare (x :*: y) (x' :*: y') = case gcompare x x' of GLT -> GLT GGT -> GGT GEQ -> case gcompare y y' of GLT -> GLT GEQ -> GEQ GGT -> GGT ------------------------------------------------------------------------------- -- Some ------------------------------------------------------------------------------- -- | Existential. This is type is useful to hide GADTs' parameters. -- -- >>> data Tag :: * -> * where TagInt :: Tag Int; TagBool :: Tag Bool -- >>> instance GShow Tag where gshowsPrec _ TagInt = showString "TagInt"; gshowsPrec _ TagBool = showString "TagBool" -- >>> classify s = case s of "TagInt" -> [mkGReadResult TagInt]; "TagBool" -> [mkGReadResult TagBool]; _ -> [] -- >>> instance GRead Tag where greadsPrec _ s = [ (r, rest) | (con, rest) <- lex s, r <- classify con ] -- -- With Church-encoding youcan only use a functions: -- -- >>> let y = mkSome TagBool -- >>> y -- mkSome TagBool -- -- >>> withSome y $ \y' -> case y' of { TagInt -> "I"; TagBool -> "B" } :: String -- "B" -- -- or explicitly work with 'S' -- -- >>> let x = S $ \f -> f TagInt -- >>> x -- mkSome TagInt -- -- >>> case x of S f -> f $ \x' -> case x' of { TagInt -> "I"; TagBool -> "B" } :: String -- "I" -- -- The implementation of 'mapSome' is /safe/. -- -- >>> let f :: Tag a -> Tag a; f TagInt = TagInt; f TagBool = TagBool -- >>> mapSome f y -- mkSome TagBool -- -- but you can also use: -- -- >>> withSome y (mkSome . f) -- mkSome TagBool -- -- >>> read "Some TagBool" :: Some Tag -- mkSome TagBool -- -- >>> read "mkSome TagInt" :: Some Tag -- mkSome TagInt -- #if __GLASGOW_HASKELL__ >= 810 type Some :: (k -> Type) -> Type #endif newtype Some tag = S { -- | Eliminator. withSome :: forall r. (forall a. tag a -> r) -> r } type role Some representational -- | Constructor. mkSome :: tag a -> Some tag mkSome t = S (\f -> f t) -- | Map over argument. mapSome :: (forall x. f x -> g x) -> Some f -> Some g mapSome nt (S fx) = S (\f -> fx (f . nt)) -- | @'flip' 'withSome'@ foldSome :: (forall a. tag a -> b) -> Some tag -> b foldSome some (S thing) = thing some -- | Traverse over argument. traverseSome :: Functor m => (forall a. f a -> m (g a)) -> Some f -> m (Some g) traverseSome f x = withSome x $ \x' -> fmap mkSome (f x') -- | Monadic 'withSome'. -- -- @since 1.0.1 withSomeM :: Monad m => m (Some tag) -> (forall a. tag a -> m r) -> m r withSomeM m k = m >>= \s -> withSome s k ------------------------------------------------------------------------------- -- Church Some instances ------------------------------------------------------------------------------- instance GShow tag => Show (Some tag) where showsPrec p some = withSome some $ \thing -> showParen (p > 10) ( showString "mkSome " . gshowsPrec 11 thing ) instance GRead f => Read (Some f) where readsPrec p = readParen (p>10) $ \s -> [ (withSome withTag mkSome, rest') | (con, rest) <- lex s , con == "Some" || con == "mkSome" , (withTag, rest') <- greadsPrec 11 rest ] instance GEq tag => Eq (Some tag) where x == y = withSome x $ \x' -> withSome y $ \y' -> defaultEq x' y' instance GCompare tag => Ord (Some tag) where compare x y = withSome x $ \x' -> withSome y $ \y' -> defaultCompare x' y' instance Control.Applicative.Applicative m => Data.Semigroup.Semigroup (Some m) where m <> n = withSome m $ \m' -> withSome n $ \n' -> mkSome (m' *> n') instance Applicative m => Data.Monoid.Monoid (Some m) where mempty = mkSome (pure ()) mappend = (<>) some-1.0.4.1/src/Data/GADT/Show.hs0000644000000000000000000000050507346545000014442 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} module Data.GADT.Show ( -- * Showing GShow (..), defaultGshowsPrec, gshows, gshow, -- * Reading GRead (..), GReadS, greads, gread, greadMaybe, getGReadResult, mkGReadResult, ) where import Data.GADT.Internal some-1.0.4.1/src/Data/0000755000000000000000000000000007346545000012447 5ustar0000000000000000some-1.0.4.1/src/Data/Some.hs0000644000000000000000000000050507346545000013706 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} -- | An existential type. -- -- The constructor is exported only on GHC-8 and later. module Data.Some ( Some(Some), mkSome, withSome, withSomeM, mapSome, foldSome, traverseSome, ) where #ifdef SOME_NEWTYPE import Data.Some.Newtype #else import Data.Some.GADT #endif some-1.0.4.1/src/Data/Some/0000755000000000000000000000000007346545000013352 5ustar0000000000000000some-1.0.4.1/src/Data/Some/Church.hs0000644000000000000000000000032107346545000015116 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} module Data.Some.Church ( Some(..), mkSome, mapSome, withSomeM, foldSome, traverseSome, ) where import Data.GADT.Internal some-1.0.4.1/src/Data/Some/GADT.hs0000644000000000000000000000735507346545000014437 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE Safe #-} #if __GLASGOW_HASKELL__ >= 810 {-# LANGUAGE StandaloneKindSignatures #-} #endif module Data.Some.GADT ( Some(Some), mkSome, withSome, withSomeM, mapSome, foldSome, traverseSome, ) where import Control.Applicative (Applicative (..)) import Control.DeepSeq (NFData (..)) import Data.Monoid (Monoid (..)) import Data.Semigroup (Semigroup (..)) #if __GLASGOW_HASKELL__ >= 810 import Data.Kind (Type) #endif import Data.GADT.Compare import Data.GADT.DeepSeq import Data.GADT.Show -- $setup -- >>> :set -XKindSignatures -XGADTs -- >>> import Data.GADT.Show -- | Existential. This is type is useful to hide GADTs' parameters. -- -- >>> data Tag :: * -> * where TagInt :: Tag Int; TagBool :: Tag Bool -- >>> instance GShow Tag where gshowsPrec _ TagInt = showString "TagInt"; gshowsPrec _ TagBool = showString "TagBool" -- >>> classify s = case s of "TagInt" -> [mkGReadResult TagInt]; "TagBool" -> [mkGReadResult TagBool]; _ -> [] -- >>> instance GRead Tag where greadsPrec _ s = [ (r, rest) | (con, rest) <- lex s, r <- classify con ] -- -- You can either use constructor: -- -- >>> let x = Some TagInt -- >>> x -- Some TagInt -- -- >>> case x of { Some TagInt -> "I"; Some TagBool -> "B" } :: String -- "I" -- -- or you can use functions -- -- >>> let y = mkSome TagBool -- >>> y -- Some TagBool -- -- >>> withSome y $ \y' -> case y' of { TagInt -> "I"; TagBool -> "B" } :: String -- "B" -- -- The implementation of 'mapSome' is /safe/. -- -- >>> let f :: Tag a -> Tag a; f TagInt = TagInt; f TagBool = TagBool -- >>> mapSome f y -- Some TagBool -- -- but you can also use: -- -- >>> withSome y (mkSome . f) -- Some TagBool -- -- >>> read "Some TagBool" :: Some Tag -- Some TagBool -- -- >>> read "mkSome TagInt" :: Some Tag -- Some TagInt -- #if __GLASGOW_HASKELL__ >= 810 type Some :: (k -> Type) -> Type #endif data Some tag where Some :: tag a -> Some tag type role Some representational -- | Constructor. mkSome :: tag a -> Some tag mkSome = Some -- | Eliminator. withSome :: Some tag -> (forall a. tag a -> b) -> b withSome (Some thing) some = some thing -- | Monadic 'withSome'. -- -- @since 1.0.1 withSomeM :: Monad m => m (Some tag) -> (forall a. tag a -> m r) -> m r withSomeM m k = m >>= \s -> withSome s k -- | @'flip' 'withSome'@ foldSome :: (forall a. tag a -> b) -> Some tag -> b foldSome some (Some thing) = some thing -- | Map over argument. mapSome :: (forall x. f x -> g x) -> Some f -> Some g mapSome nt (Some fx) = Some (nt fx) -- | Traverse over argument. traverseSome :: Functor m => (forall a. f a -> m (g a)) -> Some f -> m (Some g) traverseSome f (Some x) = fmap Some (f x) instance GShow tag => Show (Some tag) where showsPrec p (Some thing) = showParen (p > 10) $ showString "Some " . gshowsPrec 11 thing -- | instance GRead f => Read (Some f) where readsPrec p = readParen (p>10) $ \s -> [ (getGReadResult withTag Some, rest') | (con, rest) <- lex s , con == "Some" || con == "mkSome" , (withTag, rest') <- greadsPrec 11 rest ] instance GEq tag => Eq (Some tag) where Some x == Some y = defaultEq x y instance GCompare tag => Ord (Some tag) where compare (Some x) (Some y) = defaultCompare x y instance GNFData tag => NFData (Some tag) where rnf (Some x) = grnf x instance Control.Applicative.Applicative m => Data.Semigroup.Semigroup (Some m) where Some m <> Some n = Some (m *> n) instance Applicative m => Data.Monoid.Monoid (Some m) where mempty = Some (pure ()) mappend = (<>) some-1.0.4.1/src/Data/Some/Newtype.hs0000644000000000000000000001036607346545000015347 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-} #if __GLASGOW_HASKELL__ >= 810 {-# LANGUAGE StandaloneKindSignatures #-} #endif module Data.Some.Newtype ( Some(Some), mkSome, withSome, withSomeM, mapSome, foldSome, traverseSome, ) where import Control.Applicative (Applicative (..)) import Control.DeepSeq (NFData (..)) import Data.Monoid (Monoid (..)) import Data.Semigroup (Semigroup (..)) import GHC.Exts (Any) import Unsafe.Coerce (unsafeCoerce) #if __GLASGOW_HASKELL__ >= 810 import Data.Kind (Type) #endif import Data.GADT.Compare import Data.GADT.DeepSeq import Data.GADT.Show -- $setup -- >>> :set -XKindSignatures -XGADTs -- >>> import Data.GADT.Show -- | Existential. This is type is useful to hide GADTs' parameters. -- -- >>> data Tag :: * -> * where TagInt :: Tag Int; TagBool :: Tag Bool -- >>> instance GShow Tag where gshowsPrec _ TagInt = showString "TagInt"; gshowsPrec _ TagBool = showString "TagBool" -- >>> classify s = case s of "TagInt" -> [mkGReadResult TagInt]; "TagBool" -> [mkGReadResult TagBool]; _ -> [] -- >>> instance GRead Tag where greadsPrec _ s = [ (r, rest) | (con, rest) <- lex s, r <- classify con ] -- -- You can either use @PatternSynonyms@ (available with GHC >= 8.0) -- -- >>> let x = Some TagInt -- >>> x -- Some TagInt -- -- >>> case x of { Some TagInt -> "I"; Some TagBool -> "B" } :: String -- "I" -- -- or you can use functions -- -- >>> let y = mkSome TagBool -- >>> y -- Some TagBool -- -- >>> withSome y $ \y' -> case y' of { TagInt -> "I"; TagBool -> "B" } :: String -- "B" -- -- The implementation of 'mapSome' is /safe/. -- -- >>> let f :: Tag a -> Tag a; f TagInt = TagInt; f TagBool = TagBool -- >>> mapSome f y -- Some TagBool -- -- but you can also use: -- -- >>> withSome y (mkSome . f) -- Some TagBool -- -- >>> read "Some TagBool" :: Some Tag -- Some TagBool -- -- >>> read "mkSome TagInt" :: Some Tag -- Some TagInt -- #if __GLASGOW_HASKELL__ >= 810 type Some :: (k -> Type) -> Type #endif newtype Some tag = UnsafeSome (tag Any) type role Some representational {-# COMPLETE Some #-} pattern Some :: tag a -> Some tag pattern Some x <- UnsafeSome x where Some x = UnsafeSome ((unsafeCoerce :: tag a -> tag Any) x) -- | Constructor. mkSome :: tag a -> Some tag mkSome = \x -> UnsafeSome (unsafeCoerce x) -- | Eliminator. withSome :: Some tag -> (forall a. tag a -> b) -> b withSome (UnsafeSome thing) some = some (unsafeCoerce thing) -- | Monadic 'withSome'. -- -- @since 1.0.1 withSomeM :: Monad m => m (Some tag) -> (forall a. tag a -> m r) -> m r withSomeM m k = m >>= \s -> withSome s k -- | @'flip' 'withSome'@ foldSome :: (forall a. tag a -> b) -> Some tag -> b foldSome some (UnsafeSome thing) = some (unsafeCoerce thing) -- | Map over argument. mapSome :: (forall t. f t -> g t) -> Some f -> Some g mapSome f (UnsafeSome x) = UnsafeSome (unsafeCoerce f x) -- | Traverse over argument. traverseSome :: Functor m => (forall a. f a -> m (g a)) -> Some f -> m (Some g) traverseSome f x = withSome x $ \x' -> fmap mkSome (f x') instance GShow tag => Show (Some tag) where showsPrec p some = withSome some $ \thing -> showParen (p > 10) ( showString "Some " . gshowsPrec 11 thing ) instance GRead f => Read (Some f) where readsPrec p = readParen (p>10) $ \s -> [ (getGReadResult withTag mkSome, rest') | (con, rest) <- lex s , con == "Some" || con == "mkSome" , (withTag, rest') <- greadsPrec 11 rest ] instance GEq tag => Eq (Some tag) where x == y = withSome x $ \x' -> withSome y $ \y' -> defaultEq x' y' instance GCompare tag => Ord (Some tag) where compare x y = withSome x $ \x' -> withSome y $ \y' -> defaultCompare x' y' instance GNFData tag => NFData (Some tag) where rnf x = withSome x grnf instance Control.Applicative.Applicative m => Data.Semigroup.Semigroup (Some m) where m <> n = withSome m $ \m' -> withSome n $ \n' -> mkSome (m' *> n') instance Applicative m => Data.Monoid.Monoid (Some m) where mempty = mkSome (pure ()) mappend = (<>) some-1.0.4.1/test/0000755000000000000000000000000007346545000011766 5ustar0000000000000000some-1.0.4.1/test/HKD.hs0000644000000000000000000000344207346545000012733 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} module Main where import Control.Applicative as A import Data.Monoid as Mon -- from Some package import qualified Data.Some.Church as C import qualified Data.Some.GADT as G import qualified Data.Some.Newtype as N class FFoldable t where ffoldMap :: Monoid m => (forall a. f a -> m) -> t f -> m -- one derived operation, is ftraverse_, which we can implement using ffoldMap gadt_ftraverse_ :: (FFoldable t, A.Applicative m) => (forall a. f a -> m b) -> t f -> m () gadt_ftraverse_ k tf = case ffoldMap (G.Some . k) tf of G.Some mx -> () <$ mx newtype_ftraverse_ :: (FFoldable t, Applicative m) => (forall a. f a -> m b) -> t f -> m () newtype_ftraverse_ k tf = case ffoldMap (N.Some . k) tf of N.Some mx -> () <$ mx church_ftraverse_ :: (FFoldable t, Applicative m) => (forall a. f a -> m b) -> t f -> m () church_ftraverse_ k tf = C.withSome (ffoldMap (C.mkSome . k) tf) $ \mx -> () <$ mx -- ghc -c -fforce-recomp -O -ddump-simpl -dsuppress-all HKD.hs data Ex f where Nil :: Ex f Cons :: f a -> Ex f -> Ex f instance FFoldable Ex where ffoldMap f = go where go Nil = Mon.mempty go (Cons x xs) = mappend (f x) (go xs) gadt_ftraverse_Ex :: Applicative m => (forall a. f a -> m b) -> Ex f -> m () gadt_ftraverse_Ex = gadt_ftraverse_ newtype_ftraverse_Ex :: Applicative m => (forall a. f a -> m b) -> Ex f -> m () newtype_ftraverse_Ex = newtype_ftraverse_ church_ftraverse_Ex :: Applicative m => (forall a. f a -> m b) -> Ex f -> m () church_ftraverse_Ex = church_ftraverse_ ------------------------------------------------------------------------------- -- Main ------------------------------------------------------------------------------- main :: IO () main = return ()