{-# LANGUAGE CPP             #-}
{-# LANGUAGE GADTs           #-}
{-# LANGUAGE RankNTypes      #-}
#if __GLASGOW_HASKELL__ >= 801
{-# LANGUAGE PatternSynonyms #-}
#endif
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds       #-}
#endif
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy     #-}
#endif
module Data.Some.Newtype (
#if __GLASGOW_HASKELL__ >= 801
    Some(Some),
#else
    Some,
#endif
    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)

import Data.GADT.Compare
import Data.GADT.DeepSeq
import Data.GADT.Show

-- $setup
-- >>> :set -XKindSignatures -XGADTs

-- | 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
--
newtype Some tag = UnsafeSome (tag Any)
 
#if __GLASGOW_HASKELL__ >= 801
{-# COMPLETE Some #-}
pattern Some :: tag a -> Some tag
#if __GLASGOW_HASKELL__ >= 802
pattern $bSome :: tag a -> Some tag
$mSome :: forall r k (tag :: k -> *).
Some tag -> (forall (a :: k). tag a -> r) -> (Void# -> r) -> r
Some x <- UnsafeSome x
  where Some tag a
x = tag Any -> Some tag
forall k (tag :: k -> *). tag Any -> Some tag
UnsafeSome ((forall a b. a -> b
forall k (tag :: k -> *) (a :: k). tag a -> tag Any
unsafeCoerce :: tag a -> tag Any) tag a
x)
#else
-- There was a bug type checking pattern synonyms that prevented the
-- obvious thing from working.
pattern Some x <- UnsafeSome ((unsafeCoerce :: tag Any -> tag a) -> x)
  where Some x = UnsafeSome ((unsafeCoerce :: tag a -> tag Any) x)
#endif
#endif

-- | Constructor.
mkSome :: tag a -> Some tag
mkSome :: tag a -> Some tag
mkSome = \tag a
x -> tag Any -> Some tag
forall k (tag :: k -> *). tag Any -> Some tag
UnsafeSome (tag a -> tag Any
forall a b. a -> b
unsafeCoerce tag a
x)

-- | Eliminator.
withSome :: Some tag -> (forall a. tag a -> b) -> b
withSome :: Some tag -> (forall (a :: k). tag a -> b) -> b
withSome (UnsafeSome tag Any
thing) forall (a :: k). tag a -> b
some = tag Any -> b
forall (a :: k). tag a -> b
some (tag Any -> tag Any
forall a b. a -> b
unsafeCoerce tag Any
thing)

-- | Monadic 'withSome'.
--
-- @since 1.0.1
withSomeM :: Monad m => m (Some tag) -> (forall a. tag a -> m r) -> m r
withSomeM :: m (Some tag) -> (forall (a :: k). tag a -> m r) -> m r
withSomeM m (Some tag)
m forall (a :: k). tag a -> m r
k = m (Some tag)
m m (Some tag) -> (Some tag -> m r) -> m r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Some tag
s -> Some tag -> (forall (a :: k). tag a -> m r) -> m r
forall k (tag :: k -> *) b.
Some tag -> (forall (a :: k). tag a -> b) -> b
withSome Some tag
s forall (a :: k). tag a -> m r
k

-- | @'flip' 'withSome'@
foldSome :: (forall a. tag a -> b) -> Some tag -> b
foldSome :: (forall (a :: k). tag a -> b) -> Some tag -> b
foldSome forall (a :: k). tag a -> b
some (UnsafeSome tag Any
thing) = tag Any -> b
forall (a :: k). tag a -> b
some (tag Any -> tag Any
forall a b. a -> b
unsafeCoerce tag Any
thing)

-- | Map over argument.
mapSome :: (forall t. f t -> g t) -> Some f -> Some g
mapSome :: (forall (t :: k). f t -> g t) -> Some f -> Some g
mapSome forall (t :: k). f t -> g t
f (UnsafeSome f Any
x) = g Any -> Some g
forall k (tag :: k -> *). tag Any -> Some tag
UnsafeSome ((f Any -> g Any) -> f Any -> g Any
forall a b. a -> b
unsafeCoerce f Any -> g Any
forall (t :: k). f t -> g t
f f Any
x)

-- | Traverse over argument.
traverseSome :: Functor m => (forall a. f a -> m (g a)) -> Some f -> m (Some g)
traverseSome :: (forall (a :: k). f a -> m (g a)) -> Some f -> m (Some g)
traverseSome forall (a :: k). f a -> m (g a)
f Some f
x = Some f -> (forall (a :: k). f a -> m (Some g)) -> m (Some g)
forall k (tag :: k -> *) b.
Some tag -> (forall (a :: k). tag a -> b) -> b
withSome Some f
x ((forall (a :: k). f a -> m (Some g)) -> m (Some g))
-> (forall (a :: k). f a -> m (Some g)) -> m (Some g)
forall a b. (a -> b) -> a -> b
$ \f a
x' -> (g a -> Some g) -> m (g a) -> m (Some g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g a -> Some g
forall k (tag :: k -> *) (a :: k). tag a -> Some tag
mkSome (f a -> m (g a)
forall (a :: k). f a -> m (g a)
f f a
x')

instance GShow tag => Show (Some tag) where
    showsPrec :: Int -> Some tag -> ShowS
showsPrec Int
p Some tag
some = Some tag -> (forall (a :: k). tag a -> ShowS) -> ShowS
forall k (tag :: k -> *) b.
Some tag -> (forall (a :: k). tag a -> b) -> b
withSome Some tag
some ((forall (a :: k). tag a -> ShowS) -> ShowS)
-> (forall (a :: k). tag a -> ShowS) -> ShowS
forall a b. (a -> b) -> a -> b
$ \tag a
thing -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
        ( String -> ShowS
showString String
"Some "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> tag a -> ShowS
forall k (t :: k -> *) (a :: k). GShow t => Int -> t a -> ShowS
gshowsPrec Int
11 tag a
thing
        )

instance GRead f => Read (Some f) where
    readsPrec :: Int -> ReadS (Some f)
readsPrec Int
p = Bool -> ReadS (Some f) -> ReadS (Some f)
forall a. Bool -> ReadS a -> ReadS a
readParen (Int
pInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
10) (ReadS (Some f) -> ReadS (Some f))
-> ReadS (Some f) -> ReadS (Some f)
forall a b. (a -> b) -> a -> b
$ \String
s ->
        [ (Some f -> (forall (a :: k). f a -> Some f) -> Some f
forall k (tag :: k -> *) b.
Some tag -> (forall (a :: k). tag a -> b) -> b
getGReadResult Some f
withTag forall (a :: k). f a -> Some f
forall k (tag :: k -> *) (a :: k). tag a -> Some tag
mkSome, String
rest')
        | (String
con, String
rest) <- ReadS String
lex String
s
        , String
con String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Some" Bool -> Bool -> Bool
|| String
con String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"mkSome"
        , (Some f
withTag, String
rest') <- Int -> GReadS f
forall k (t :: k -> *). GRead t => Int -> GReadS t
greadsPrec Int
11 String
rest
        ]

instance GEq tag => Eq (Some tag) where
    Some tag
x == :: Some tag -> Some tag -> Bool
== Some tag
y =
        Some tag -> (forall (a :: k). tag a -> Bool) -> Bool
forall k (tag :: k -> *) b.
Some tag -> (forall (a :: k). tag a -> b) -> b
withSome Some tag
x ((forall (a :: k). tag a -> Bool) -> Bool)
-> (forall (a :: k). tag a -> Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ \tag a
x' ->
        Some tag -> (forall (a :: k). tag a -> Bool) -> Bool
forall k (tag :: k -> *) b.
Some tag -> (forall (a :: k). tag a -> b) -> b
withSome Some tag
y ((forall (a :: k). tag a -> Bool) -> Bool)
-> (forall (a :: k). tag a -> Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ \tag a
y' -> tag a -> tag a -> Bool
forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Bool
defaultEq tag a
x' tag a
y'

instance GCompare tag => Ord (Some tag) where
    compare :: Some tag -> Some tag -> Ordering
compare Some tag
x Some tag
y =
        Some tag -> (forall (a :: k). tag a -> Ordering) -> Ordering
forall k (tag :: k -> *) b.
Some tag -> (forall (a :: k). tag a -> b) -> b
withSome Some tag
x ((forall (a :: k). tag a -> Ordering) -> Ordering)
-> (forall (a :: k). tag a -> Ordering) -> Ordering
forall a b. (a -> b) -> a -> b
$ \tag a
x' ->
        Some tag -> (forall (a :: k). tag a -> Ordering) -> Ordering
forall k (tag :: k -> *) b.
Some tag -> (forall (a :: k). tag a -> b) -> b
withSome Some tag
y ((forall (a :: k). tag a -> Ordering) -> Ordering)
-> (forall (a :: k). tag a -> Ordering) -> Ordering
forall a b. (a -> b) -> a -> b
$ \tag a
y' -> tag a -> tag a -> Ordering
forall k (f :: k -> *) (a :: k) (b :: k).
GCompare f =>
f a -> f b -> Ordering
defaultCompare tag a
x' tag a
y'

instance GNFData tag => NFData (Some tag) where
    rnf :: Some tag -> ()
rnf Some tag
x = Some tag -> (forall a. tag a -> ()) -> ()
forall k (tag :: k -> *) b.
Some tag -> (forall (a :: k). tag a -> b) -> b
withSome Some tag
x forall a. tag a -> ()
forall (f :: * -> *) a. GNFData f => f a -> ()
grnf

instance Control.Applicative.Applicative m => Data.Semigroup.Semigroup (Some m) where
    Some m
m <> :: Some m -> Some m -> Some m
<> Some m
n =
        Some m -> (forall a. m a -> Some m) -> Some m
forall k (tag :: k -> *) b.
Some tag -> (forall (a :: k). tag a -> b) -> b
withSome Some m
m ((forall a. m a -> Some m) -> Some m)
-> (forall a. m a -> Some m) -> Some m
forall a b. (a -> b) -> a -> b
$ \m a
m' ->
        Some m -> (forall a. m a -> Some m) -> Some m
forall k (tag :: k -> *) b.
Some tag -> (forall (a :: k). tag a -> b) -> b
withSome Some m
n ((forall a. m a -> Some m) -> Some m)
-> (forall a. m a -> Some m) -> Some m
forall a b. (a -> b) -> a -> b
$ \m a
n' ->
        m a -> Some m
forall k (tag :: k -> *) (a :: k). tag a -> Some tag
mkSome (m a
m' m a -> m a -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a
n')

instance Applicative m => Data.Monoid.Monoid (Some m) where
    mempty :: Some m
mempty = m () -> Some m
forall k (tag :: k -> *) (a :: k). tag a -> Some tag
mkSome (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    mappend :: Some m -> Some m -> Some m
mappend = Some m -> Some m -> Some m
forall a. Semigroup a => a -> a -> a
(<>)