dependent-sum-0.4/0000755000000000000000000000000012762407541012323 5ustar0000000000000000dependent-sum-0.4/dependent-sum.cabal0000644000000000000000000000356312762407541016066 0ustar0000000000000000name: dependent-sum version: 0.4 stability: provisional cabal-version: >= 1.6 build-type: Simple author: James Cook maintainer: James Cook license: PublicDomain homepage: https://github.com/mokus0/dependent-sum category: Data, Dependent Types synopsis: Dependent sum type description: A dependent sum is a generalization of a particular way of thinking about the @Either@ type. @Either a b@ can be thought of as a 2-tuple @(tag, value)@, where the value of the tag determines the type of the value. In particular, either @tag = Left@ and @value :: a@ or @tag = Right@ and @value :: b@. . This package allows you to define your own dependent sum types by using your own \"tag\" types. tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1, GHC == 7.11 extra-source-files: examples/*.hs source-repository head type: git location: git://github.com/mokus0/dependent-sum.git Library hs-source-dirs: src exposed-modules: Data.Dependent.Sum Data.GADT.Compare Data.GADT.Show Data.Some if impl(ghc < 7.8) other-modules: Data.Dependent.Sum.Typeable build-depends: base >= 3 && <5 if impl(ghc >= 7.2) ghc-options: -trust base dependent-sum-0.4/Setup.lhs0000644000000000000000000000011612762407541014131 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain dependent-sum-0.4/examples/0000755000000000000000000000000012762407541014141 5ustar0000000000000000dependent-sum-0.4/examples/FooGADT.hs0000644000000000000000000000470212762407541015663 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} module FooGADT where import Data.Dependent.Sum import Data.Functor.Identity import Data.GADT.Show import Data.GADT.Compare data Foo a where Foo :: Foo Double Bar :: Foo Int Baz :: Foo String Qux :: Foo Double instance Eq (Foo a) where (==) = defaultEq instance GEq Foo where geq Foo Foo = Just Refl geq Bar Bar = Just Refl geq Baz Baz = Just Refl geq Qux Qux = Just Refl geq _ _ = Nothing instance EqTag Foo Identity where eqTagged Foo Foo = (==) eqTagged Bar Bar = (==) eqTagged Baz Baz = (==) eqTagged Qux Qux = (==) eqTagged _ _ = const (const False) instance GCompare Foo where gcompare Foo Foo = GEQ gcompare Foo _ = GLT gcompare _ Foo = GGT gcompare Bar Bar = GEQ gcompare Bar _ = GLT gcompare _ Bar = GGT gcompare Baz Baz = GEQ gcompare Baz _ = GLT gcompare _ Baz = GGT gcompare Qux Qux = GEQ instance OrdTag Foo Identity where compareTagged Foo Foo = compare compareTagged Bar Bar = compare compareTagged Baz Baz = compare compareTagged Qux Qux = compare compareTagged _ _ = error "OrdTag (Foo): bad case" instance Show (Foo a) where showsPrec _ Foo = showString "Foo" showsPrec _ Bar = showString "Bar" showsPrec _ Baz = showString "Baz" showsPrec _ Qux = showString "Qux" instance GShow Foo where gshowsPrec = showsPrec instance ShowTag Foo Identity where showTaggedPrec Foo = showsPrec showTaggedPrec Bar = showsPrec showTaggedPrec Baz = showsPrec showTaggedPrec Qux = showsPrec instance GRead Foo where greadsPrec _ str = case tag of "Foo" -> [(GReadResult (\k -> k Foo), rest)] "Bar" -> [(GReadResult (\k -> k Bar), rest)] "Baz" -> [(GReadResult (\k -> k Baz), rest)] "Qux" -> [(GReadResult (\k -> k Qux), rest)] _ -> [] where (tag, rest) = splitAt 3 str instance ReadTag Foo Identity where readTaggedPrec Foo = readsPrec readTaggedPrec Bar = readsPrec readTaggedPrec Baz = readsPrec readTaggedPrec Qux = readsPrec foo :: Double -> DSum Foo Identity foo x = Foo ==> x bar :: Int -> DSum Foo Identity bar x = Bar ==> x baz :: String -> DSum Foo Identity baz x = Baz ==> x qux :: Double -> DSum Foo Identity qux x = Qux ==> x xs = [foo pi, bar 100, baz "hello world", qux (exp 1)] xs' = read (show xs) `asTypeOf` xsdependent-sum-0.4/src/0000755000000000000000000000000012762407541013112 5ustar0000000000000000dependent-sum-0.4/src/Data/0000755000000000000000000000000012762407541013763 5ustar0000000000000000dependent-sum-0.4/src/Data/Some.hs0000644000000000000000000000210412762407541015217 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PolyKinds #-} #endif module Data.Some where import Data.GADT.Show import Data.GADT.Compare import Data.Maybe data Some tag where This :: !(tag t) -> Some tag withSome :: Some tag -> (forall a. tag a -> b) -> b withSome (This thing) some = some thing instance GShow tag => Show (Some tag) where showsPrec p (This thing) = showParen (p > 10) ( showString "This " . gshowsPrec 11 thing ) instance GRead f => Read (Some f) where readsPrec p = readParen (p>10) $ \s -> [ (getGReadResult withTag This, rest') | let (con, rest) = splitAt 5 s , con == "This " , (withTag, rest') <- greadsPrec 11 rest ] instance GEq tag => Eq (Some tag) where This x == This y = defaultEq x y instance GCompare tag => Ord (Some tag) where compare (This x) (This y) = defaultCompare x y dependent-sum-0.4/src/Data/Dependent/0000755000000000000000000000000012762407541015671 5ustar0000000000000000dependent-sum-0.4/src/Data/Dependent/Sum.hs0000644000000000000000000002007312762407541016773 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification, GADTs #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PolyKinds #-} #endif module Data.Dependent.Sum where import Control.Applicative #if MIN_VERSION_base(4,7,0) import Data.Typeable (Typeable) #else import Data.Dependent.Sum.Typeable ({- instance Typeable ... -}) #endif import Data.GADT.Show import Data.GADT.Compare import Data.Maybe (fromMaybe) -- |A basic dependent sum type; the first component is a tag that specifies -- the type of the second; for example, think of a GADT such as: -- -- > data Tag a where -- > AString :: Tag String -- > AnInt :: Tag Int -- -- Then, we have the following valid expressions of type @Applicative f => DSum Tag f@: -- -- > AString ==> "hello!" -- > AnInt ==> 42 -- -- And we can write functions that consume @DSum Tag f@ values by matching, -- such as: -- -- > toString :: DSum Tag Identity -> String -- > toString (AString :=> Identity str) = str -- > toString (AnInt :=> Identity int) = show int -- -- By analogy to the (key => value) construction for dictionary entries in -- many dynamic languages, we use (key :=> value) as the constructor for -- dependent sums. The :=> and ==> operators have very low precedence and -- bind to the right, so if the @Tag@ GADT is extended with an additional -- constructor @Rec :: Tag (DSum Tag Identity)@, then @Rec ==> AnInt ==> 3 + 4@ -- is parsed as would be expected (@Rec ==> (AnInt ==> (3 + 4))@) and has type -- @DSum Identity Tag@. Its precedence is just above that of '$', so -- @foo bar $ AString ==> "eep"@ is equivalent to @foo bar (AString ==> "eep")@. data DSum tag f = forall a. !(tag a) :=> f a #if MIN_VERSION_base(4,7,0) deriving Typeable #endif infixr 1 :=>, ==> (==>) :: Applicative f => tag a -> a -> DSum tag f k ==> v = k :=> pure v -- |In order to make a 'Show' instance for @DSum tag f@, @tag@ must be able -- to show itself as well as any value of the tagged type. 'GShow' together -- with this class provides the interface by which it can do so. -- -- @ShowTag tag f => t@ is conceptually equivalent to something like this -- imaginary syntax: @(forall a. Inhabited (tag a) => Show (f a)) => t@, -- where 'Inhabited' is an imaginary predicate that characterizes -- non-empty types, and 'f' and 'a' do not occur free in 't'. -- -- The @Tag@ example type introduced in the 'DSum' section could be given the -- following instances, among others: -- -- > instance GShow Tag where -- > gshowsPrec _p AString = showString "AString" -- > gshowsPrec _p AnInt = showString "AnInt" -- > instance ShowTag Tag [] where -- > showTaggedPrec AString = showsPrec -- > showTaggedPrec AnInt = showsPrec -- class GShow tag => ShowTag tag f where -- |Given a value of type @tag a@, return the 'showsPrec' function for -- the type @f a@. showTaggedPrec :: tag a -> Int -> f a -> ShowS instance Show (f a) => ShowTag ((:=) a) f where showTaggedPrec Refl = showsPrec -- This instance is questionable. It works, but is pretty useless. instance Show (f a) => ShowTag (GOrdering a) f where showTaggedPrec GEQ = showsPrec showTaggedPrec _ = \p _ -> showParen (p > 10) ( showString "error " . shows "type information lost into the mists of oblivion" ) instance ShowTag tag f => Show (DSum tag f) where showsPrec p (tag :=> value) = showParen (p >= 10) ( gshowsPrec 0 tag . showString " :=> " . showTaggedPrec tag 1 value ) class GRead tag => ReadTag tag f where readTaggedPrec :: tag a -> Int -> ReadS (f a) -- |In order to make a 'Read' instance for @DSum tag f@, @tag@ must be able -- to parse itself as well as any value of the tagged type. 'GRead' together -- with this class provides the interface by which it can do so. -- -- @ReadTag tag f => t@ is conceptually equivalent to something like this -- imaginary syntax: @(forall a. Inhabited (tag a) => Read (f a)) => t@, -- where 'Inhabited' is an imaginary predicate that characterizes -- non-empty types, and 'f' and 'a' do not occur free in 't'. -- -- The @Tag@ example type introduced in the 'DSum' section could be given the -- following instances, among others: -- -- > instance GRead Tag where -- > greadsPrec _p str = case tag of -- > "AString" -> [(\k -> k AString, rest)] -- > "AnInt" -> [(\k -> k AnInt, rest)] -- > _ -> [] -- > where (tag, rest) = break isSpace str -- > instance ReadTag Tag [] where -- > readTaggedPrec AString = readsPrec -- > readTaggedPrec AnInt = readsPrec -- instance Read (f a) => ReadTag ((:=) a) f where readTaggedPrec Refl = readsPrec -- This instance is questionable. It works, but is partial (and is also pretty useless) -- instance Read a => ReadTag (GOrdering a) where -- readTaggedPrec GEQ = readsPrec -- readTaggedPrec tag = \p -> readParen (p>10) $ \s -> -- [ (error msg, rest') -- | let (con, rest) = splitAt 6 s -- , con == "error " -- , (msg, rest') <- reads rest :: [(String, String)] -- ] instance ReadTag tag f => Read (DSum tag f) where readsPrec p = readParen (p > 1) $ \s -> concat [ getGReadResult withTag $ \tag -> [ (tag :=> val, rest'') | (val, rest'') <- readTaggedPrec tag 1 rest' ] | (withTag, rest) <- greadsPrec p s , let (con, rest') = splitAt 5 rest , con == " :=> " ] -- |In order to test @DSum tag f@ for equality, @tag@ must know how to test -- both itself and its tagged values for equality. 'EqTag' defines -- the interface by which they are expected to do so. -- -- Continuing the @Tag@ example from the 'DSum' section, we can define: -- -- > instance GEq Tag where -- > geq AString AString = Just Refl -- > geq AnInt AnInt = Just Refl -- > geq _ _ = Nothing -- > instance EqTag Tag [] where -- > eqTagged AString AString = (==) -- > eqTagged AnInt AnInt = (==) -- -- Note that 'eqTagged' is not called until after the tags have been -- compared, so it only needs to consider the cases where 'gcompare' returns 'GEQ'. class GEq tag => EqTag tag f where -- |Given two values of type @tag a@ (for which 'gcompare' returns 'GEQ'), -- return the '==' function for the type @f a@. eqTagged :: tag a -> tag a -> f a -> f a -> Bool instance Eq (f a) => EqTag ((:=) a) f where eqTagged Refl Refl = (==) instance EqTag tag f => Eq (DSum tag f) where (t1 :=> x1) == (t2 :=> x2) = fromMaybe False $ do Refl <- geq t1 t2 return (eqTagged t1 t2 x1 x2) -- |In order to compare @DSum tag f@ values, @tag@ must know how to compare -- both itself and its tagged values. 'OrdTag' defines the -- interface by which they are expected to do so. -- -- Continuing the @Tag@ example from the 'EqTag' section, we can define: -- -- > instance GCompare Tag where -- > gcompare AString AString = GEQ -- > gcompare AString AnInt = GLT -- > gcompare AnInt AString = GGT -- > gcompare AnInt AnInt = GEQ -- > instance OrdTag Tag [] where -- > compareTagged AString AString = compare -- > compareTagged AnInt AnInt = compare -- -- As with 'eqTagged', 'compareTagged' only needs to consider cases where -- 'gcompare' returns 'GEQ'. class (EqTag tag f, GCompare tag) => OrdTag tag f where -- |Given two values of type @tag a@ (for which 'gcompare' returns 'GEQ'), -- return the 'compare' function for the type @f a@. compareTagged :: tag a -> tag a -> f a -> f a -> Ordering instance Ord (f a) => OrdTag ((:=) a) f where compareTagged Refl Refl = compare instance OrdTag tag f => Ord (DSum tag f) where compare (t1 :=> x1) (t2 :=> x2) = case gcompare t1 t2 of GLT -> LT GGT -> GT GEQ -> compareTagged t1 t2 x1 x2 dependent-sum-0.4/src/Data/Dependent/Sum.hs-boot0000644000000000000000000000022512762407541017731 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification, TypeOperators #-} module Data.Dependent.Sum where data DSum tag f = forall a. !(tag a) :=> f a infixr 1 :=> dependent-sum-0.4/src/Data/Dependent/Sum/0000755000000000000000000000000012762407541016435 5ustar0000000000000000dependent-sum-0.4/src/Data/Dependent/Sum/Typeable.hs0000644000000000000000000000170312762407541020537 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif -- |Separate module for Typeable declaration, to minimize the amount of -- visual inspection required to determine that this package is "safe" -- -- This separation is not necessary with base >= 4.7, so this module will -- not be compiled at all with GHC >= 7.8. module Data.Dependent.Sum.Typeable where import {-# SOURCE #-} Data.Dependent.Sum import Data.Typeable instance (Typeable1 t, Typeable1 f) => Typeable (DSum t f) where typeOf ds = mkTyConApp dSumCon [typeOfF, typeOfT] where typeOfF = typeOf1 $ (undefined :: DSum f t -> f a) ds typeOfT = typeOf1 $ (undefined :: DSum f t -> t a) ds #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 dSumCon = mkTyCon3 "dependent-sum" "Data.Dependent.Sum" "DSum" #else dSumCon = mkTyCon "Data.Dependent.Sum.DSum" #endifdependent-sum-0.4/src/Data/GADT/0000755000000000000000000000000012762407541014502 5ustar0000000000000000dependent-sum-0.4/src/Data/GADT/Compare.hs0000644000000000000000000001242112762407541016424 0ustar0000000000000000{-# LANGUAGE GADTs, TypeOperators, RankNTypes, TypeFamilies, FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-warn-deprecated-flags #-} {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PolyKinds #-} #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif {-# LANGUAGE ScopedTypeVariables #-} module Data.GADT.Compare ( module Data.GADT.Compare #if MIN_VERSION_base(4,7,0) , (:~:)(Refl) #endif ) where import Data.Maybe import Data.GADT.Show import Data.Typeable #if MIN_VERSION_base(4,7,0) -- |Backwards compatibility alias; as of GHC 7.8, this is the same as `(:~:)`. type (:=) = (:~:) #else -- |A GADT witnessing equality of two types. Its only inhabitant is 'Refl'. data a := b where Refl :: a := a deriving Typeable instance Eq (a := b) where Refl == Refl = True instance Ord (a := b) where compare Refl Refl = EQ instance Show (a := b) where showsPrec _ Refl = showString "Refl" instance Read (a := a) where readsPrec _ s = case con of "Refl" -> [(Refl, rest)] _ -> [] where (con,rest) = splitAt 4 s #endif instance GShow ((:=) a) where gshowsPrec _ Refl = showString "Refl" instance GRead ((:=) a) where greadsPrec p s = readsPrec p s >>= f where f :: forall x. (x := x, String) -> [(GReadResult ((:=) x), String)] f (Refl, rest) = return (GReadResult (\x -> x Refl) , rest) -- |A class for type-contexts which contain enough information -- to (at least in some cases) decide the equality of types -- occurring within them. 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 "Data.Dependent.Sum" in both examples) geq :: f a -> f b -> Maybe (a := b) -- |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) -- 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. data GOrdering a b where GLT :: GOrdering a b GEQ :: GOrdering t t GGT :: GOrdering a b deriving Typeable -- |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" -> [(GReadResult (\x -> x GGT), rest)] "GEQ" -> [(GReadResult (\x -> x GEQ), rest)] "GLT" -> [(GReadResult (\x -> x 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'). class GEq f => GCompare f where gcompare :: f a -> f b -> GOrdering a b instance GCompare ((:=) a) where gcompare Refl Refl = GEQ defaultCompare :: GCompare f => f a -> f b -> Ordering defaultCompare x y = weakenOrdering (gcompare x y) dependent-sum-0.4/src/Data/GADT/Show.hs0000644000000000000000000000316212762407541015760 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PolyKinds #-} #endif module Data.GADT.Show where -- |'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 = showsPrec class GShow t where gshowsPrec :: Int -> t a -> ShowS gshows :: GShow t => t a -> ShowS gshows = gshowsPrec (-1) gshow :: (GShow t) => t a -> String gshow x = gshows x "" newtype GReadResult t = GReadResult { getGReadResult :: forall b . (forall a . t a -> b) -> b } -- |@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@) type GReadS t = String -> [(GReadResult t, String)] -- |'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. 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 = case hd [f | (f, "") <- greads s] of GReadResult res -> res g where hd (x:_) = x hd _ = error "gread: no parse"