module Patrol.Type.EventId where import qualified Control.Monad as Monad import qualified Control.Monad.Catch as Catch import qualified Control.Monad.IO.Class as IO import qualified Data.Aeson as Aeson import qualified Data.Text as Text import qualified Data.Text.Read as Text import qualified Data.Typeable as Typeable import qualified Data.UUID as Uuid import qualified Data.UUID.V4 as Uuid import qualified Patrol.Exception.Problem as Problem import qualified Text.Printf as Printf newtype EventId = EventId Uuid.UUID deriving (EventId -> EventId -> Bool (EventId -> EventId -> Bool) -> (EventId -> EventId -> Bool) -> Eq EventId forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a $c== :: EventId -> EventId -> Bool == :: EventId -> EventId -> Bool $c/= :: EventId -> EventId -> Bool /= :: EventId -> EventId -> Bool Eq, Int -> EventId -> ShowS [EventId] -> ShowS EventId -> String (Int -> EventId -> ShowS) -> (EventId -> String) -> ([EventId] -> ShowS) -> Show EventId forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> EventId -> ShowS showsPrec :: Int -> EventId -> ShowS $cshow :: EventId -> String show :: EventId -> String $cshowList :: [EventId] -> ShowS showList :: [EventId] -> ShowS Show) instance Aeson.FromJSON EventId where parseJSON :: Value -> Parser EventId parseJSON = let name :: String name = TypeRep -> String forall a. Show a => a -> String show (TypeRep -> String) -> TypeRep -> String forall a b. (a -> b) -> a -> b $ Proxy EventId -> TypeRep forall {k} (proxy :: k -> *) (a :: k). Typeable a => proxy a -> TypeRep Typeable.typeRep (Proxy EventId forall {k} (t :: k). Proxy t Typeable.Proxy :: Typeable.Proxy EventId) in String -> (Text -> Parser EventId) -> Value -> Parser EventId forall a. String -> (Text -> Parser a) -> Value -> Parser a Aeson.withText String name ((Text -> Parser EventId) -> Value -> Parser EventId) -> (Text -> Parser EventId) -> Value -> Parser EventId forall a b. (a -> b) -> a -> b $ Parser EventId -> (EventId -> Parser EventId) -> Maybe EventId -> Parser EventId forall b a. b -> (a -> b) -> Maybe a -> b maybe (String -> Parser EventId forall a. String -> Parser a forall (m :: * -> *) a. MonadFail m => String -> m a fail (String -> Parser EventId) -> String -> Parser EventId forall a b. (a -> b) -> a -> b $ String "invalid " String -> ShowS forall a. Semigroup a => a -> a -> a <> String name) EventId -> Parser EventId forall a. a -> Parser a forall (f :: * -> *) a. Applicative f => a -> f a pure (Maybe EventId -> Parser EventId) -> (Text -> Maybe EventId) -> Text -> Parser EventId forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> Maybe EventId forall (m :: * -> *). MonadThrow m => Text -> m EventId fromText instance Aeson.ToJSON EventId where toJSON :: EventId -> Value toJSON = Text -> Value forall a. ToJSON a => a -> Value Aeson.toJSON (Text -> Value) -> (EventId -> Text) -> EventId -> Value forall b c a. (b -> c) -> (a -> b) -> a -> c . EventId -> Text intoText empty :: EventId empty :: EventId empty = UUID -> EventId fromUuid UUID Uuid.nil fromUuid :: Uuid.UUID -> EventId fromUuid :: UUID -> EventId fromUuid = UUID -> EventId EventId intoUuid :: EventId -> Uuid.UUID intoUuid :: EventId -> UUID intoUuid (EventId UUID uuid) = UUID uuid random :: (IO.MonadIO io) => io EventId random :: forall (io :: * -> *). MonadIO io => io EventId random = IO EventId -> io EventId forall a. IO a -> io a forall (m :: * -> *) a. MonadIO m => IO a -> m a IO.liftIO (IO EventId -> io EventId) -> IO EventId -> io EventId forall a b. (a -> b) -> a -> b $ (UUID -> EventId) -> IO UUID -> IO EventId forall a b. (a -> b) -> IO a -> IO b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap UUID -> EventId fromUuid IO UUID Uuid.nextRandom intoText :: EventId -> Text.Text intoText :: EventId -> Text intoText EventId eventId = let (Word64 lo, Word64 hi) = UUID -> (Word64, Word64) Uuid.toWords64 (UUID -> (Word64, Word64)) -> UUID -> (Word64, Word64) forall a b. (a -> b) -> a -> b $ EventId -> UUID intoUuid EventId eventId in String -> Text Text.pack (String -> Text) -> String -> Text forall a b. (a -> b) -> a -> b $ String -> Word64 -> Word64 -> String forall r. PrintfType r => String -> r Printf.printf String "%016x%016x" Word64 lo Word64 hi fromText :: (Catch.MonadThrow m) => Text.Text -> m EventId fromText :: forall (m :: * -> *). MonadThrow m => Text -> m EventId fromText Text t1 = do let parse :: (Catch.MonadThrow n, Integral a) => Int -> Text.Text -> n (a, Text.Text) parse :: forall (n :: * -> *) a. (MonadThrow n, Integral a) => Int -> Text -> n (a, Text) parse Int size Text text = do let (Text before, Text after) = Int -> Text -> (Text, Text) Text.splitAt Int size Text text case Text -> Int -> Ordering Text.compareLength Text before Int size of Ordering GT -> Problem -> n (a, Text) forall e a. (HasCallStack, Exception e) => e -> n a forall (m :: * -> *) e a. (MonadThrow m, HasCallStack, Exception e) => e -> m a Catch.throwM (Problem -> n (a, Text)) -> Problem -> n (a, Text) forall a b. (a -> b) -> a -> b $ String -> Problem Problem.Problem String "impossible" Ordering LT -> Problem -> n (a, Text) forall e a. (HasCallStack, Exception e) => e -> n a forall (m :: * -> *) e a. (MonadThrow m, HasCallStack, Exception e) => e -> m a Catch.throwM (Problem -> n (a, Text)) -> Problem -> n (a, Text) forall a b. (a -> b) -> a -> b $ String -> Problem Problem.Problem String "not enough input" Ordering EQ -> case Reader a forall a. Integral a => Reader a Text.hexadecimal Text before of Left String _ -> Problem -> n (a, Text) forall e a. (HasCallStack, Exception e) => e -> n a forall (m :: * -> *) e a. (MonadThrow m, HasCallStack, Exception e) => e -> m a Catch.throwM (Problem -> n (a, Text)) -> Problem -> n (a, Text) forall a b. (a -> b) -> a -> b $ String -> Problem Problem.Problem String "invalid hexadecimal" Right (a integral, Text leftover) -> if Text -> Bool Text.null Text leftover then (a, Text) -> n (a, Text) forall a. a -> n a forall (f :: * -> *) a. Applicative f => a -> f a pure (a integral, Text after) else Problem -> n (a, Text) forall e a. (HasCallStack, Exception e) => e -> n a forall (m :: * -> *) e a. (MonadThrow m, HasCallStack, Exception e) => e -> m a Catch.throwM (Problem -> n (a, Text)) -> Problem -> n (a, Text) forall a b. (a -> b) -> a -> b $ String -> Problem Problem.Problem String "invalid hexadecimal" (Word64 lo, Text t2) <- Int -> Text -> m (Word64, Text) forall (n :: * -> *) a. (MonadThrow n, Integral a) => Int -> Text -> n (a, Text) parse Int 16 Text t1 (Word64 hi, Text t3) <- Int -> Text -> m (Word64, Text) forall (n :: * -> *) a. (MonadThrow n, Integral a) => Int -> Text -> n (a, Text) parse Int 16 Text t2 Bool -> m () -> m () forall (f :: * -> *). Applicative f => Bool -> f () -> f () Monad.unless (Text -> Bool Text.null Text t3) (m () -> m ()) -> (Problem -> m ()) -> Problem -> m () forall b c a. (b -> c) -> (a -> b) -> a -> c . Problem -> m () forall e a. (HasCallStack, Exception e) => e -> m a forall (m :: * -> *) e a. (MonadThrow m, HasCallStack, Exception e) => e -> m a Catch.throwM (Problem -> m ()) -> Problem -> m () forall a b. (a -> b) -> a -> b $ String -> Problem Problem.Problem String "too much input" EventId -> m EventId forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure (EventId -> m EventId) -> (UUID -> EventId) -> UUID -> m EventId forall b c a. (b -> c) -> (a -> b) -> a -> c . UUID -> EventId fromUuid (UUID -> m EventId) -> UUID -> m EventId forall a b. (a -> b) -> a -> b $ Word64 -> Word64 -> UUID Uuid.fromWords64 Word64 lo Word64 hi