{-# LANGUAGE DeriveAnyClass  #-}
{-# LANGUAGE OverloadedStrings  #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Ext
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- A pair-like data type to represent a 'core' type that has extra information
-- as well.
--
--------------------------------------------------------------------------------
module Data.Ext where

import Control.DeepSeq
import Control.Lens hiding ((.=))
import Data.Aeson
import Data.Aeson.Types (typeMismatch)
import Data.Biapplicative
import Data.Bifoldable
import Data.Bifunctor.Apply
import Data.Bitraversable
import Data.Functor.Apply (liftF2)
import Data.Semigroup.Bifoldable
import Data.Semigroup.Bitraversable
import GHC.Generics (Generic)
import Test.QuickCheck

--------------------------------------------------------------------------------

-- | Our Ext type that represents the core datatype core extended with extra
-- information of type 'extra'.
data core :+ extra = core :+ extra deriving (Int -> (core :+ extra) -> ShowS
[core :+ extra] -> ShowS
(core :+ extra) -> String
(Int -> (core :+ extra) -> ShowS)
-> ((core :+ extra) -> String)
-> ([core :+ extra] -> ShowS)
-> Show (core :+ extra)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall core extra.
(Show core, Show extra) =>
Int -> (core :+ extra) -> ShowS
forall core extra.
(Show core, Show extra) =>
[core :+ extra] -> ShowS
forall core extra.
(Show core, Show extra) =>
(core :+ extra) -> String
showList :: [core :+ extra] -> ShowS
$cshowList :: forall core extra.
(Show core, Show extra) =>
[core :+ extra] -> ShowS
show :: (core :+ extra) -> String
$cshow :: forall core extra.
(Show core, Show extra) =>
(core :+ extra) -> String
showsPrec :: Int -> (core :+ extra) -> ShowS
$cshowsPrec :: forall core extra.
(Show core, Show extra) =>
Int -> (core :+ extra) -> ShowS
Show,ReadPrec [core :+ extra]
ReadPrec (core :+ extra)
Int -> ReadS (core :+ extra)
ReadS [core :+ extra]
(Int -> ReadS (core :+ extra))
-> ReadS [core :+ extra]
-> ReadPrec (core :+ extra)
-> ReadPrec [core :+ extra]
-> Read (core :+ extra)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall core extra.
(Read core, Read extra) =>
ReadPrec [core :+ extra]
forall core extra.
(Read core, Read extra) =>
ReadPrec (core :+ extra)
forall core extra.
(Read core, Read extra) =>
Int -> ReadS (core :+ extra)
forall core extra. (Read core, Read extra) => ReadS [core :+ extra]
readListPrec :: ReadPrec [core :+ extra]
$creadListPrec :: forall core extra.
(Read core, Read extra) =>
ReadPrec [core :+ extra]
readPrec :: ReadPrec (core :+ extra)
$creadPrec :: forall core extra.
(Read core, Read extra) =>
ReadPrec (core :+ extra)
readList :: ReadS [core :+ extra]
$creadList :: forall core extra. (Read core, Read extra) => ReadS [core :+ extra]
readsPrec :: Int -> ReadS (core :+ extra)
$creadsPrec :: forall core extra.
(Read core, Read extra) =>
Int -> ReadS (core :+ extra)
Read,(core :+ extra) -> (core :+ extra) -> Bool
((core :+ extra) -> (core :+ extra) -> Bool)
-> ((core :+ extra) -> (core :+ extra) -> Bool)
-> Eq (core :+ extra)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall core extra.
(Eq core, Eq extra) =>
(core :+ extra) -> (core :+ extra) -> Bool
/= :: (core :+ extra) -> (core :+ extra) -> Bool
$c/= :: forall core extra.
(Eq core, Eq extra) =>
(core :+ extra) -> (core :+ extra) -> Bool
== :: (core :+ extra) -> (core :+ extra) -> Bool
$c== :: forall core extra.
(Eq core, Eq extra) =>
(core :+ extra) -> (core :+ extra) -> Bool
Eq,Eq (core :+ extra)
Eq (core :+ extra)
-> ((core :+ extra) -> (core :+ extra) -> Ordering)
-> ((core :+ extra) -> (core :+ extra) -> Bool)
-> ((core :+ extra) -> (core :+ extra) -> Bool)
-> ((core :+ extra) -> (core :+ extra) -> Bool)
-> ((core :+ extra) -> (core :+ extra) -> Bool)
-> ((core :+ extra) -> (core :+ extra) -> core :+ extra)
-> ((core :+ extra) -> (core :+ extra) -> core :+ extra)
-> Ord (core :+ extra)
(core :+ extra) -> (core :+ extra) -> Bool
(core :+ extra) -> (core :+ extra) -> Ordering
(core :+ extra) -> (core :+ extra) -> core :+ extra
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall core extra. (Ord core, Ord extra) => Eq (core :+ extra)
forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> Bool
forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> Ordering
forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> core :+ extra
min :: (core :+ extra) -> (core :+ extra) -> core :+ extra
$cmin :: forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> core :+ extra
max :: (core :+ extra) -> (core :+ extra) -> core :+ extra
$cmax :: forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> core :+ extra
>= :: (core :+ extra) -> (core :+ extra) -> Bool
$c>= :: forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> Bool
> :: (core :+ extra) -> (core :+ extra) -> Bool
$c> :: forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> Bool
<= :: (core :+ extra) -> (core :+ extra) -> Bool
$c<= :: forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> Bool
< :: (core :+ extra) -> (core :+ extra) -> Bool
$c< :: forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> Bool
compare :: (core :+ extra) -> (core :+ extra) -> Ordering
$ccompare :: forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> Ordering
$cp1Ord :: forall core extra. (Ord core, Ord extra) => Eq (core :+ extra)
Ord,core :+ extra
(core :+ extra) -> (core :+ extra) -> Bounded (core :+ extra)
forall a. a -> a -> Bounded a
forall core extra. (Bounded core, Bounded extra) => core :+ extra
maxBound :: core :+ extra
$cmaxBound :: forall core extra. (Bounded core, Bounded extra) => core :+ extra
minBound :: core :+ extra
$cminBound :: forall core extra. (Bounded core, Bounded extra) => core :+ extra
Bounded,(forall x. (core :+ extra) -> Rep (core :+ extra) x)
-> (forall x. Rep (core :+ extra) x -> core :+ extra)
-> Generic (core :+ extra)
forall x. Rep (core :+ extra) x -> core :+ extra
forall x. (core :+ extra) -> Rep (core :+ extra) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall core extra x. Rep (core :+ extra) x -> core :+ extra
forall core extra x. (core :+ extra) -> Rep (core :+ extra) x
$cto :: forall core extra x. Rep (core :+ extra) x -> core :+ extra
$cfrom :: forall core extra x. (core :+ extra) -> Rep (core :+ extra) x
Generic,(core :+ extra) -> ()
((core :+ extra) -> ()) -> NFData (core :+ extra)
forall a. (a -> ()) -> NFData a
forall core extra.
(NFData core, NFData extra) =>
(core :+ extra) -> ()
rnf :: (core :+ extra) -> ()
$crnf :: forall core extra.
(NFData core, NFData extra) =>
(core :+ extra) -> ()
NFData)
infixr 1 :+


instance Bifunctor (:+) where
  bimap :: (a -> b) -> (c -> d) -> (a :+ c) -> b :+ d
bimap a -> b
f c -> d
g (a
c :+ c
e) = a -> b
f a
c b -> d -> b :+ d
forall core extra. core -> extra -> core :+ extra
:+ c -> d
g c
e

instance Biapply (:+) where
  (a -> b
f :+ c -> d
g) <<.>> :: ((a -> b) :+ (c -> d)) -> (a :+ c) -> b :+ d
<<.>> (a
c :+ c
e) = a -> b
f a
c b -> d -> b :+ d
forall core extra. core -> extra -> core :+ extra
:+ c -> d
g c
e

instance Biapplicative (:+) where
  bipure :: a -> b -> a :+ b
bipure = a -> b -> a :+ b
forall core extra. core -> extra -> core :+ extra
(:+)
  (a -> b
f :+ c -> d
g) <<*>> :: ((a -> b) :+ (c -> d)) -> (a :+ c) -> b :+ d
<<*>> (a
c :+ c
e) = a -> b
f a
c b -> d -> b :+ d
forall core extra. core -> extra -> core :+ extra
:+ c -> d
g c
e

instance Bifoldable (:+) where
  bifoldMap :: (a -> m) -> (b -> m) -> (a :+ b) -> m
bifoldMap a -> m
f b -> m
g (a
c :+ b
e) = a -> m
f a
c m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` b -> m
g b
e

instance Bitraversable (:+) where
  bitraverse :: (a -> f c) -> (b -> f d) -> (a :+ b) -> f (c :+ d)
bitraverse a -> f c
f b -> f d
g (a
c :+ b
e) = c -> d -> c :+ d
forall core extra. core -> extra -> core :+ extra
(:+) (c -> d -> c :+ d) -> f c -> f (d -> c :+ d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
c f (d -> c :+ d) -> f d -> f (c :+ d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> f d
g b
e

instance Bifoldable1 (:+)

instance Bitraversable1 (:+) where
  bitraverse1 :: (a -> f b) -> (c -> f d) -> (a :+ c) -> f (b :+ d)
bitraverse1 a -> f b
f c -> f d
g (a
c :+ c
e) = (b -> d -> b :+ d) -> f b -> f d -> f (b :+ d)
forall (f :: * -> *) a b c.
Apply f =>
(a -> b -> c) -> f a -> f b -> f c
liftF2 b -> d -> b :+ d
forall core extra. core -> extra -> core :+ extra
(:+) (a -> f b
f a
c) (c -> f d
g c
e)

instance (Semigroup core, Semigroup extra) => Semigroup (core :+ extra) where
  (core
c :+ extra
e) <> :: (core :+ extra) -> (core :+ extra) -> core :+ extra
<> (core
c' :+ extra
e') = core
c core -> core -> core
forall a. Semigroup a => a -> a -> a
<> core
c' core -> extra -> core :+ extra
forall core extra. core -> extra -> core :+ extra
:+ extra
e extra -> extra -> extra
forall a. Semigroup a => a -> a -> a
<> extra
e'


instance (ToJSON core, ToJSON extra) => ToJSON (core :+ extra) where
  -- toJSON     (c :+ e) = toJSON     (c,e)
  -- toEncoding (c :+ e) = toEncoding (c,e)
  toJSON :: (core :+ extra) -> Value
toJSON     (core
c :+ extra
e) = [Pair] -> Value
object [Text
"core" Text -> core -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= core
c, Text
"extra" Text -> extra -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= extra
e]
  toEncoding :: (core :+ extra) -> Encoding
toEncoding (core
c :+ extra
e) = Series -> Encoding
pairs  (Text
"core" Text -> core -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= core
c Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
"extra" Text -> extra -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= extra
e)

instance (FromJSON core, FromJSON extra) => FromJSON (core :+ extra) where
  -- parseJSON = fmap (\(c,e) -> c :+ e) . parseJSON
  parseJSON :: Value -> Parser (core :+ extra)
parseJSON (Object Object
v) = core -> extra -> core :+ extra
forall core extra. core -> extra -> core :+ extra
(:+) (core -> extra -> core :+ extra)
-> Parser core -> Parser (extra -> core :+ extra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser core
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"core" Parser (extra -> core :+ extra)
-> Parser extra -> Parser (core :+ extra)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser extra
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"extra"
  parseJSON Value
invalid    = String -> Value -> Parser (core :+ extra)
forall a. String -> Value -> Parser a
typeMismatch String
"Ext (:+)" Value
invalid

instance (Arbitrary c, Arbitrary e) => Arbitrary (c :+ e) where
  arbitrary :: Gen (c :+ e)
arbitrary = c -> e -> c :+ e
forall core extra. core -> extra -> core :+ extra
(:+) (c -> e -> c :+ e) -> Gen c -> Gen (e -> c :+ e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen c
forall a. Arbitrary a => Gen a
arbitrary Gen (e -> c :+ e) -> Gen e -> Gen (c :+ e)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen e
forall a. Arbitrary a => Gen a
arbitrary

-- | Access the core of an extended value.
_core :: (core :+ extra) -> core
_core :: (core :+ extra) -> core
_core (core
c :+ extra
_) = core
c
{-# INLINABLE _core #-}

-- | Access the extra part of an extended value.
_extra :: (core :+ extra) -> extra
_extra :: (core :+ extra) -> extra
_extra (core
_ :+ extra
e) = extra
e
{-# INLINABLE _extra #-}

-- | Lens access to the core of an extended value.
core :: Lens (core :+ extra) (core' :+ extra) core core'
core :: (core -> f core') -> (core :+ extra) -> f (core' :+ extra)
core = ((core :+ extra) -> core)
-> ((core :+ extra) -> core' -> core' :+ extra)
-> Lens (core :+ extra) (core' :+ extra) core core'
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (core :+ extra) -> core
forall core extra. (core :+ extra) -> core
_core (\(core
_ :+ extra
e) core'
c -> core'
c core' -> extra -> core' :+ extra
forall core extra. core -> extra -> core :+ extra
:+ extra
e)
{-# INLINABLE core #-}

-- | Lens access to the extra part of an extended value.
extra :: Lens (core :+ extra) (core :+ extra') extra extra'
extra :: (extra -> f extra') -> (core :+ extra) -> f (core :+ extra')
extra = ((core :+ extra) -> extra)
-> ((core :+ extra) -> extra' -> core :+ extra')
-> Lens (core :+ extra) (core :+ extra') extra extra'
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (core :+ extra) -> extra
forall core extra. (core :+ extra) -> extra
_extra (\(core
c :+ extra
_) extra'
e -> core
c core -> extra' -> core :+ extra'
forall core extra. core -> extra -> core :+ extra
:+ extra'
e)
{-# INLINABLE extra #-}

-- | Tag a value with the unit type.
ext   :: a -> a :+ ()
ext :: a -> a :+ ()
ext a
x = a
x a -> () -> a :+ ()
forall core extra. core -> extra -> core :+ extra
:+ ()
{-# INLINABLE ext #-}