{-# LANGUAGE CPP #-}

module OpenXR.Internal.Utils
  ( enumReadPrec
  , enumShowsPrec
  , traceAroundEvent
  ) where

import           Data.Foldable
import           Debug.Trace
import           GHC.Read                       ( expectP )
import           Text.ParserCombinators.ReadP   ( skipSpaces
                                                , string
                                                )
import           Text.Read

-- | The common bits of enumeration and bitmask read instances
enumReadPrec
  :: Read i
  => String
  -- ^ The common constructor prefix
  -> [(a, String)]
  -- ^ The table of values to constructor suffixes
  -> String
  -- ^ The newtype constructor name
  -> (i -> a)
  -- ^ The newtype constructor
  -> ReadPrec a
enumReadPrec :: String -> [(a, String)] -> String -> (i -> a) -> ReadPrec a
enumReadPrec prefix :: String
prefix table :: [(a, String)]
table conName :: String
conName con :: i -> a
con = ReadPrec a -> ReadPrec a
forall a. ReadPrec a -> ReadPrec a
parens
  (   ReadP a -> ReadPrec a
forall a. ReadP a -> ReadPrec a
lift
      (do
        ReadP ()
skipSpaces
        String
_ <- String -> ReadP String
string String
prefix
        [ReadP a] -> ReadP a
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ((\(e :: a
e, s :: String
s) -> a
e a -> ReadP String -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string String
s) ((a, String) -> ReadP a) -> [(a, String)] -> [ReadP a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, String)]
table)
      )
  ReadPrec a -> ReadPrec a -> ReadPrec a
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ Prec -> ReadPrec a -> ReadPrec a
forall a. Prec -> ReadPrec a -> ReadPrec a
prec
        10
        (do
          Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Ident String
conName)
          i
v <- ReadPrec i -> ReadPrec i
forall a. ReadPrec a -> ReadPrec a
step ReadPrec i
forall a. Read a => ReadPrec a
readPrec
          a -> ReadPrec a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (i -> a
con i
v)
        )
  )

-- | The common bits of enumeration and bitmask show instances
enumShowsPrec
  :: Eq a
  => String
  -- ^ The common constructor prefix
  -> [(a, String)]
  -- ^ A table of values to constructor suffixes
  -> String
  -- ^ The newtype constructor name
  -> (a -> i)
  -- ^ Unpack the newtype
  -> (i -> ShowS)
  -- ^ Show the underlying value
  -> Int
  -> a
  -> ShowS
enumShowsPrec :: String
-> [(a, String)]
-> String
-> (a -> i)
-> (i -> ShowS)
-> Prec
-> a
-> ShowS
enumShowsPrec prefix :: String
prefix table :: [(a, String)]
table conName :: String
conName getInternal :: a -> i
getInternal showsInternal :: i -> ShowS
showsInternal p :: Prec
p e :: a
e =
  case a -> [(a, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
e [(a, String)]
table of
    Just s :: String
s -> String -> ShowS
showString String
prefix ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
s
    Nothing ->
      let x :: i
x = a -> i
getInternal a
e
      in  Bool -> ShowS -> ShowS
showParen (Prec
p Prec -> Prec -> Bool
forall a. Ord a => a -> a -> Bool
>= 11)
                    (String -> ShowS
showString String
conName ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> ShowS
showsInternal i
x)

-- | Wrap an IO action with a pair of 'traceEventIO' using the specified
-- message with "begin" or "end" appended.
traceAroundEvent :: String -> IO a -> IO a
#if defined(TRACE_CALLS)
traceAroundEvent msg a =
  traceEventIO (msg <> " begin") *> a <* traceEventIO (msg <> " end")
#else
traceAroundEvent :: String -> IO a -> IO a
traceAroundEvent _ a :: IO a
a = IO a
a
#endif