{-# 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 ()
#endif
import Data.GADT.Show
import Data.GADT.Compare
import Data.Maybe (fromMaybe)
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
tag a
k ==> :: tag a -> a -> DSum tag f
==> a
v = tag a
k tag a -> f a -> DSum tag f
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
class GShow tag => ShowTag tag f where
showTaggedPrec :: tag a -> Int -> f a -> ShowS
instance Show (f a) => ShowTag ((:=) a) f where
showTaggedPrec :: (a := a) -> Int -> f a -> ShowS
showTaggedPrec a := a
Refl = Int -> f a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec
instance Show (f a) => ShowTag (GOrdering a) f where
showTaggedPrec :: GOrdering a a -> Int -> f a -> ShowS
showTaggedPrec GOrdering a a
GEQ = Int -> f a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec
showTaggedPrec GOrdering a a
_ = \Int
p f a
_ -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
( String -> ShowS
showString String
"error "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Show a => a -> ShowS
shows String
"type information lost into the mists of oblivion"
)
instance ShowTag tag f => Show (DSum tag f) where
showsPrec :: Int -> DSum tag f -> ShowS
showsPrec Int
p (tag a
tag :=> f a
value) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10)
( Int -> tag a -> ShowS
forall k (t :: k -> *) (a :: k). GShow t => Int -> t a -> ShowS
gshowsPrec Int
0 tag a
tag
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" :=> "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. tag a -> Int -> f a -> ShowS
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
ShowTag tag f =>
tag a -> Int -> f a -> ShowS
showTaggedPrec tag a
tag Int
1 f a
value
)
class GRead tag => ReadTag tag f where
readTaggedPrec :: tag a -> Int -> ReadS (f a)
instance Read (f a) => ReadTag ((:=) a) f where
readTaggedPrec :: (a := a) -> Int -> ReadS (f a)
readTaggedPrec a := a
Refl = Int -> ReadS (f a)
forall a. Read a => Int -> ReadS a
readsPrec
instance ReadTag tag f => Read (DSum tag f) where
readsPrec :: Int -> ReadS (DSum tag f)
readsPrec Int
p = Bool -> ReadS (DSum tag f) -> ReadS (DSum tag f)
forall a. Bool -> ReadS a -> ReadS a
readParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (ReadS (DSum tag f) -> ReadS (DSum tag f))
-> ReadS (DSum tag f) -> ReadS (DSum tag f)
forall a b. (a -> b) -> a -> b
$ \String
s ->
[[(DSum tag f, String)]] -> [(DSum tag f, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ GReadResult tag -> forall b. (forall (a :: k). tag a -> b) -> b
forall k (t :: k -> *).
GReadResult t -> forall b. (forall (a :: k). t a -> b) -> b
getGReadResult GReadResult tag
withTag ((forall (a :: k). tag a -> [(DSum tag f, String)])
-> [(DSum tag f, String)])
-> (forall (a :: k). tag a -> [(DSum tag f, String)])
-> [(DSum tag f, String)]
forall a b. (a -> b) -> a -> b
$ \tag a
tag ->
[ (tag a
tag tag a -> f a -> DSum tag f
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> f a
val, String
rest'')
| (f a
val, String
rest'') <- tag a -> Int -> ReadS (f a)
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
ReadTag tag f =>
tag a -> Int -> ReadS (f a)
readTaggedPrec tag a
tag Int
1 String
rest'
]
| (GReadResult tag
withTag, String
rest) <- Int -> GReadS tag
forall k (t :: k -> *). GRead t => Int -> GReadS t
greadsPrec Int
p String
s
, let (String
con, String
rest') = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
5 String
rest
, String
con String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
" :=> "
]
class GEq tag => EqTag tag f where
eqTagged :: tag a -> tag a -> f a -> f a -> Bool
instance Eq (f a) => EqTag ((:=) a) f where
eqTagged :: (a := a) -> (a := a) -> f a -> f a -> Bool
eqTagged a := a
Refl a := a
Refl = f a -> f a -> Bool
forall a. Eq a => a -> a -> Bool
(==)
instance EqTag tag f => Eq (DSum tag f) where
(tag a
t1 :=> f a
x1) == :: DSum tag f -> DSum tag f -> Bool
== (tag a
t2 :=> f a
x2) = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
a :~: a
Refl <- tag a -> tag a -> Maybe (a :~: a)
forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a := b)
geq tag a
t1 tag a
t2
Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (tag a -> tag a -> f a -> f a -> Bool
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
EqTag tag f =>
tag a -> tag a -> f a -> f a -> Bool
eqTagged tag a
t1 tag a
tag a
t2 f a
x1 f a
f a
x2)
class (EqTag tag f, GCompare tag) => OrdTag tag f where
compareTagged :: tag a -> tag a -> f a -> f a -> Ordering
instance Ord (f a) => OrdTag ((:=) a) f where
compareTagged :: (a := a) -> (a := a) -> f a -> f a -> Ordering
compareTagged a := a
Refl a := a
Refl = f a -> f a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
instance OrdTag tag f => Ord (DSum tag f) where
compare :: DSum tag f -> DSum tag f -> Ordering
compare (tag a
t1 :=> f a
x1) (tag a
t2 :=> f a
x2) = case tag a -> tag a -> GOrdering a a
forall k (f :: k -> *) (a :: k) (b :: k).
GCompare f =>
f a -> f b -> GOrdering a b
gcompare tag a
t1 tag a
t2 of
GOrdering a a
GLT -> Ordering
LT
GOrdering a a
GGT -> Ordering
GT
GOrdering a a
GEQ -> tag a -> tag a -> f a -> f a -> Ordering
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
OrdTag tag f =>
tag a -> tag a -> f a -> f a -> Ordering
compareTagged tag a
t1 tag a
tag a
t2 f a
x1 f a
f a
x2