{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}

module Events where

import           Data.Text (Text)
import           Data.Typeable
import           Data.Aeson
import           GHC.Generics

{-|

This for events intended for the front end

-}
data ForFrontEndEvent m = ForFrontEndEvent
  { forall m. ForFrontEndEvent m -> Text
event :: Text
  , forall m. ForFrontEndEvent m -> m
message :: m
  } deriving ((forall x. ForFrontEndEvent m -> Rep (ForFrontEndEvent m) x)
-> (forall x. Rep (ForFrontEndEvent m) x -> ForFrontEndEvent m)
-> Generic (ForFrontEndEvent m)
forall x. Rep (ForFrontEndEvent m) x -> ForFrontEndEvent m
forall x. ForFrontEndEvent m -> Rep (ForFrontEndEvent m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall m x. Rep (ForFrontEndEvent m) x -> ForFrontEndEvent m
forall m x. ForFrontEndEvent m -> Rep (ForFrontEndEvent m) x
$cto :: forall m x. Rep (ForFrontEndEvent m) x -> ForFrontEndEvent m
$cfrom :: forall m x. ForFrontEndEvent m -> Rep (ForFrontEndEvent m) x
Generic, Int -> ForFrontEndEvent m -> ShowS
[ForFrontEndEvent m] -> ShowS
ForFrontEndEvent m -> String
(Int -> ForFrontEndEvent m -> ShowS)
-> (ForFrontEndEvent m -> String)
-> ([ForFrontEndEvent m] -> ShowS)
-> Show (ForFrontEndEvent m)
forall m. Show m => Int -> ForFrontEndEvent m -> ShowS
forall m. Show m => [ForFrontEndEvent m] -> ShowS
forall m. Show m => ForFrontEndEvent m -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ForFrontEndEvent m] -> ShowS
$cshowList :: forall m. Show m => [ForFrontEndEvent m] -> ShowS
show :: ForFrontEndEvent m -> String
$cshow :: forall m. Show m => ForFrontEndEvent m -> String
showsPrec :: Int -> ForFrontEndEvent m -> ShowS
$cshowsPrec :: forall m. Show m => Int -> ForFrontEndEvent m -> ShowS
Show)

instance ToJSON m => ToJSON (ForFrontEndEvent m) where
  toEncoding :: ForFrontEndEvent m -> Encoding
toEncoding = Options -> ForFrontEndEvent m -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions

{-|

These encapsulate events that come from the front end in addition to events
that are internal.  For example, state changes or messages being sent to
handlers higher up in the tree.

-}
data Event where
  Event ::
    { Event -> Text
event :: Text
    , Event -> Value
message :: Value
    , Event -> Maybe [Int]
location :: Maybe [Int]
    } -> Event

  StateChangeEvent
    :: ( Eq state
       , Typeable state
       , ToJSON state
       , FromJSON state)
    => (state -> state) -> Maybe [Int] -> Event

instance Show Event where
  show :: Event -> String
show (Event Text
event Value
message Maybe [Int]
location) =
    ShowS
forall a. Show a => a -> String
show ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"{ event: "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
event
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", message: "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
message
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", location: "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe [Int] -> String
forall a. Show a => a -> String
show Maybe [Int]
location String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" }"
  show (StateChangeEvent state -> state
_ Maybe [Int]
location) =
    String
"{ event: \"newState\", location: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe [Int] -> String
forall a. Show a => a -> String
show Maybe [Int]
location String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" }"

instance Eq Event where
  (Event { $sel:message:Event :: Event -> Value
message=Value
messageA, $sel:event:Event :: Event -> Text
event=Text
eventA, $sel:location:Event :: Event -> Maybe [Int]
location=Maybe [Int]
locationA })
    == :: Event -> Event -> Bool
== (Event { $sel:message:Event :: Event -> Value
message=Value
messageB, $sel:event:Event :: Event -> Text
event=Text
eventB, $sel:location:Event :: Event -> Maybe [Int]
location=Maybe [Int]
locationB }) =
    Text
eventA Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
eventB Bool -> Bool -> Bool
&& Value
messageA Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
messageB Bool -> Bool -> Bool
&& Maybe [Int]
locationA Maybe [Int] -> Maybe [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe [Int]
locationB
  (Event {}) == Event
_ = Bool
False
  (StateChangeEvent state -> state
_ Maybe [Int]
_) == Event
_ = Bool
False

instance FromJSON Event where
  parseJSON :: Value -> Parser Event
parseJSON (Object Object
o) =
      Text -> Value -> Maybe [Int] -> Event
Event (Text -> Value -> Maybe [Int] -> Event)
-> Parser Text -> Parser (Value -> Maybe [Int] -> Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"event" Parser (Value -> Maybe [Int] -> Event)
-> Parser Value -> Parser (Maybe [Int] -> Event)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"message") Parser (Maybe [Int] -> Event)
-> Parser (Maybe [Int]) -> Parser Event
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe [Int])
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"location"
  parseJSON Value
_ = String -> Parser Event
forall a. HasCallStack => String -> a
error String
"fail"

{-|

This is for creating events that should go to a parent handler,
or sent back in to the same handler.

-}
data DirectedEvent a b = Parent a | Self b
  deriving ((forall x. DirectedEvent a b -> Rep (DirectedEvent a b) x)
-> (forall x. Rep (DirectedEvent a b) x -> DirectedEvent a b)
-> Generic (DirectedEvent a b)
forall x. Rep (DirectedEvent a b) x -> DirectedEvent a b
forall x. DirectedEvent a b -> Rep (DirectedEvent a b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b x. Rep (DirectedEvent a b) x -> DirectedEvent a b
forall a b x. DirectedEvent a b -> Rep (DirectedEvent a b) x
$cto :: forall a b x. Rep (DirectedEvent a b) x -> DirectedEvent a b
$cfrom :: forall a b x. DirectedEvent a b -> Rep (DirectedEvent a b) x
Generic, Int -> DirectedEvent a b -> ShowS
[DirectedEvent a b] -> ShowS
DirectedEvent a b -> String
(Int -> DirectedEvent a b -> ShowS)
-> (DirectedEvent a b -> String)
-> ([DirectedEvent a b] -> ShowS)
-> Show (DirectedEvent a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> DirectedEvent a b -> ShowS
forall a b. (Show a, Show b) => [DirectedEvent a b] -> ShowS
forall a b. (Show a, Show b) => DirectedEvent a b -> String
showList :: [DirectedEvent a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [DirectedEvent a b] -> ShowS
show :: DirectedEvent a b -> String
$cshow :: forall a b. (Show a, Show b) => DirectedEvent a b -> String
showsPrec :: Int -> DirectedEvent a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> DirectedEvent a b -> ShowS
Show, DirectedEvent a b -> DirectedEvent a b -> Bool
(DirectedEvent a b -> DirectedEvent a b -> Bool)
-> (DirectedEvent a b -> DirectedEvent a b -> Bool)
-> Eq (DirectedEvent a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b.
(Eq a, Eq b) =>
DirectedEvent a b -> DirectedEvent a b -> Bool
/= :: DirectedEvent a b -> DirectedEvent a b -> Bool
$c/= :: forall a b.
(Eq a, Eq b) =>
DirectedEvent a b -> DirectedEvent a b -> Bool
== :: DirectedEvent a b -> DirectedEvent a b -> Bool
$c== :: forall a b.
(Eq a, Eq b) =>
DirectedEvent a b -> DirectedEvent a b -> Bool
Eq)

instance (ToJSON a, ToJSON b) => ToJSON (DirectedEvent a b) where
  toEncoding :: DirectedEvent a b -> Encoding
toEncoding = Options -> DirectedEvent a b -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions