{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Internal utils for the other Api modules
module Cardano.Api.Internal.Utils
  ( (?!)
  , (?!.)
  , (<<$>>)
  , (<<<$>>>)
  , formatParsecError
  , failEither
  , failEitherWith
  , noInlineMaybeToStrictMaybe
  , note
  , readFileBlocking
  , runParsecParser
  , textShow

    -- ** CLI option parsing
  , unsafeBoundedRational
  )
where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Shelley ()

import Control.Exception (bracket)
import Data.Aeson.Types qualified as Aeson
import Data.ByteString qualified as BS
import Data.ByteString.Builder qualified as Builder
import Data.ByteString.Lazy qualified as LBS
import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Typeable
import GHC.IO.Handle.FD (openFileBlocking)
import GHC.Stack
import System.IO (IOMode (ReadMode), hClose)
import Text.Parsec qualified as Parsec
import Text.Parsec.String qualified as Parsec
import Text.ParserCombinators.Parsec.Error qualified as Parsec

(?!) :: Maybe a -> e -> Either e a
Maybe a
Nothing ?! :: forall a e. Maybe a -> e -> Either e a
?! e
e = e -> Either e a
forall a b. a -> Either a b
Left e
e
Just a
x ?! e
_ = a -> Either e a
forall a b. b -> Either a b
Right a
x

(?!.) :: Either e a -> (e -> e') -> Either e' a
Left e
e ?!. :: forall e a e'. Either e a -> (e -> e') -> Either e' a
?!. e -> e'
f = e' -> Either e' a
forall a b. a -> Either a b
Left (e -> e'
f e
e)
Right a
x ?!. e -> e'
_ = a -> Either e' a
forall a b. b -> Either a b
Right a
x

infixl 4 <<$>>

(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
<<$>> :: forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
(<<$>>) = (g a -> g b) -> f (g a) -> f (g b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((g a -> g b) -> f (g a) -> f (g b))
-> ((a -> b) -> g a -> g b) -> (a -> b) -> f (g a) -> f (g b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> g a -> g b
forall a b. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

infixl 4 <<<$>>>

(<<<$>>>) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b))
<<<$>>> :: forall (f :: * -> *) (g :: * -> *) (h :: * -> *) a b.
(Functor f, Functor g, Functor h) =>
(a -> b) -> f (g (h a)) -> f (g (h b))
(<<<$>>>) = (g (h a) -> g (h b)) -> f (g (h a)) -> f (g (h b))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((g (h a) -> g (h b)) -> f (g (h a)) -> f (g (h b)))
-> ((a -> b) -> g (h a) -> g (h b))
-> (a -> b)
-> f (g (h a))
-> f (g (h b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (h a -> h b) -> g (h a) -> g (h b)
forall a b. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((h a -> h b) -> g (h a) -> g (h b))
-> ((a -> b) -> h a -> h b) -> (a -> b) -> g (h a) -> g (h b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> h a -> h b
forall a b. (a -> b) -> h a -> h b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

{-# NOINLINE noInlineMaybeToStrictMaybe #-}
noInlineMaybeToStrictMaybe :: Maybe a -> StrictMaybe a
noInlineMaybeToStrictMaybe :: forall a. Maybe a -> StrictMaybe a
noInlineMaybeToStrictMaybe Maybe a
Nothing = StrictMaybe a
forall a. StrictMaybe a
SNothing
noInlineMaybeToStrictMaybe (Just a
x) = a -> StrictMaybe a
forall a. a -> StrictMaybe a
SJust a
x

formatParsecError :: Parsec.ParseError -> String
formatParsecError :: ParseError -> String
formatParsecError ParseError
err =
  String
-> String -> String -> String -> String -> [Message] -> String
Parsec.showErrorMessages
    String
"or"
    String
"unknown parse error"
    String
"expecting"
    String
"unexpected"
    String
"end of input"
    ([Message] -> String) -> [Message] -> String
forall a b. (a -> b) -> a -> b
$ ParseError -> [Message]
Parsec.errorMessages ParseError
err

runParsecParser :: Parsec.Parser a -> Text -> Aeson.Parser a
runParsecParser :: forall a. Parser a -> Text -> Parser a
runParsecParser Parser a
parser Text
input =
  case Parser a -> String -> String -> Either ParseError a
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
Parsec.parse (Parser a
parser Parser a -> ParsecT String () Identity () -> Parser a
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
Parsec.eof) String
"" (Text -> String
Text.unpack Text
input) of
    Right a
txin -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
txin
    Left ParseError
parseError -> String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ ParseError -> String
formatParsecError ParseError
parseError

failEither :: MonadFail m => Either String a -> m a
failEither :: forall (m :: * -> *) a. MonadFail m => Either String a -> m a
failEither = (String -> m a) -> (a -> m a) -> Either String a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

failEitherWith :: MonadFail m => (e -> String) -> Either e a -> m a
failEitherWith :: forall (m :: * -> *) e a.
MonadFail m =>
(e -> String) -> Either e a -> m a
failEitherWith e -> String
f = (e -> m a) -> (a -> m a) -> Either e a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> (e -> String) -> e -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
f) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

note :: MonadFail m => String -> Maybe a -> m a
note :: forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
note String
msg = \case
  Maybe a
Nothing -> String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg
  Just a
a -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

readFileBlocking :: FilePath -> IO BS.ByteString
readFileBlocking :: String -> IO ByteString
readFileBlocking String
path =
  IO Handle
-> (Handle -> IO ()) -> (Handle -> IO ByteString) -> IO ByteString
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    (String -> IOMode -> IO Handle
openFileBlocking String
path IOMode
ReadMode)
    Handle -> IO ()
hClose
    ( \Handle
fp -> do
        -- An arbitrary block size.
        let blockSize :: Int
blockSize = Int
4096
        let go :: Builder -> IO Builder
go Builder
acc = do
              ByteString
next <- Handle -> Int -> IO ByteString
BS.hGet Handle
fp Int
blockSize
              if ByteString -> Bool
BS.null ByteString
next
                then Builder -> IO Builder
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Builder
acc
                else Builder -> IO Builder
go (Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.byteString ByteString
next)
        Builder
contents <- Builder -> IO Builder
go Builder
forall a. Monoid a => a
mempty
        ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ LazyByteString -> ByteString
LBS.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> LazyByteString
Builder.toLazyByteString Builder
contents
    )

textShow :: Show a => a -> Text
textShow :: forall a. Show a => a -> Text
textShow = String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-- | Convert Rational to a bounded rational. Throw an exception when the rational is out of bounds.
unsafeBoundedRational
  :: forall r
   . (HasCallStack, Typeable r, BoundedRational r)
  => Rational
  -> r
unsafeBoundedRational :: forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundedRational Rational
x = r -> Maybe r -> r
forall a. a -> Maybe a -> a
fromMaybe (String -> r
forall a. HasCallStack => String -> a
error String
errMessage) (Maybe r -> r) -> Maybe r -> r
forall a b. (a -> b) -> a -> b
$ Rational -> Maybe r
forall r. BoundedRational r => Rational -> Maybe r
boundRational Rational
x
 where
  errMessage :: String
errMessage = TypeRep -> String
forall a. Show a => a -> String
show (Proxy r -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is out of bounds: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Rational -> String
forall a. Show a => a -> String
show Rational
x