{-# 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
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

-- |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 :: (a := a) -> Int -> f a -> ShowS
showTaggedPrec a := a
Refl = Int -> f a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

-- This instance is questionable.  It works, but is pretty useless.
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)

-- |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 :: (a := a) -> Int -> ReadS (f a)
readTaggedPrec a := a
Refl = Int -> ReadS (f a)
forall a. Read a => Int -> ReadS a
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 :: 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
" :=> "
            ]

-- |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 :: (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)

-- |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 :: (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