module GHC.Stack.Profiler.Internal.Util (
  castPtrToWord64,

  -- * Glob Patterns
  Glob,
  matches,

  -- * DList
  DList,

  -- * WriterT
  WriterT,
  tell,
  runWriterT,
) where

import Control.Monad.IO.Class (MonadIO (..))
import Data.String (IsString (..))
import Data.Word
import Foreign.Ptr
import GHC.IsList (IsList (..))

castPtrToWord64 :: Ptr a -> Word64
castPtrToWord64 :: forall a. Ptr a -> Word64
castPtrToWord64 Ptr a
ptr = case Ptr a -> WordPtr
forall a. Ptr a -> WordPtr
ptrToWordPtr Ptr a
ptr of
  WordPtr Word
w -> Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w -- On platforms that use 32-bit systems, the key is still Word64

-------------------------------------------------------------------------------
-- Glob
-------------------------------------------------------------------------------

-- NOTE: The `Glob` type (but not its implementation) is part of the public API.

-- | A glob pattern.
--
--   Use `fromString` to construct glob patterns from strings.
--
--   A @*@ matches any string, including the empty string.
--
--   One can remove the special meaning of @*@ by preceding it with a backslash.
--
--  @since 0.5.0.0
newtype Glob = Glob [GlobPart]

data GlobPart = Wildcard | Literal String

instance IsString Glob where
  fromString :: String -> Glob
  fromString :: String -> Glob
fromString = [GlobPart] -> Glob
Glob ([GlobPart] -> Glob) -> (String -> [GlobPart]) -> String -> Glob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [GlobPart]
go
   where
    go :: String -> [GlobPart]
    go :: String -> [GlobPart]
go [] = []
    go (Char
'*' : String
pat) = GlobPart
Wildcard GlobPart -> [GlobPart] -> [GlobPart]
forall a. a -> [a] -> [a]
: String -> [GlobPart]
go String
pat
    go (Char
'\\' : Char
'*' : String
pat) = String -> [GlobPart] -> [GlobPart]
literal [Char
'*'] (String -> [GlobPart]
go String
pat)
    go (Char
c : String
pat) = String -> [GlobPart] -> [GlobPart]
literal [Char
c] (String -> [GlobPart]
go String
pat)

    literal :: String -> [GlobPart] -> [GlobPart]
    literal :: String -> [GlobPart] -> [GlobPart]
literal String
lit (Literal String
lit' : [GlobPart]
pat) = String -> GlobPart
Literal (String
lit String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
lit') GlobPart -> [GlobPart] -> [GlobPart]
forall a. a -> [a] -> [a]
: [GlobPart]
pat
    literal String
lit [GlobPart]
pat = String -> GlobPart
Literal String
lit GlobPart -> [GlobPart] -> [GlobPart]
forall a. a -> [a] -> [a]
: [GlobPart]
pat

instance Show Glob where
  showsPrec :: Int -> Glob -> ShowS
  showsPrec :: Int -> Glob -> String -> String
showsPrec Int
p (Glob [GlobPart]
pat) = Int -> String -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
p ([GlobPart] -> String
go [GlobPart]
pat)
   where
    go :: [GlobPart] -> String
go [] = []
    go (GlobPart
Wildcard : [GlobPart]
pat') = Char
'*' Char -> String -> String
forall a. a -> [a] -> [a]
: [GlobPart] -> String
go [GlobPart]
pat'
    go (Literal String
lit : [GlobPart]
pat') = String -> String
escape String
lit String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [GlobPart] -> String
go [GlobPart]
pat'

    escape :: String -> String
    escape :: String -> String
escape [] = []
    escape (Char
'*' : String
str) = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'*' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
escape String
str
    escape (Char
c : String
str) = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
escape String
str

-- NOTE: The `matches` function is part of the public API.

-- | Test if the given `Glob` pattern matches the given `String`.
--
--   @since 0.5.0.0
matches :: Glob -> String -> Bool
matches :: Glob -> String -> Bool
matches (Glob [GlobPart]
parts) = [GlobPart] -> String -> Bool
go [GlobPart]
parts
 where
  go :: [GlobPart] -> String -> Bool
go [] String
_str = Bool
True
  go [GlobPart
Wildcard] String
_str = Bool
True
  go (GlobPart
Wildcard : pat' :: [GlobPart]
pat'@(GlobPart
Wildcard : [GlobPart]
_)) String
str = [GlobPart] -> String -> Bool
go [GlobPart]
pat' String
str
  go (GlobPart
Wildcard : Literal String
lit : [GlobPart]
pat') String
str = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([GlobPart] -> String -> Bool
go [GlobPart]
pat') (String -> String -> [String]
skipWildcardLiteral String
lit String
str)
  go (Literal String
lit : [GlobPart]
pat') String
str = Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ([GlobPart] -> String -> Bool
go [GlobPart]
pat') (String -> String -> Maybe String
skipPrefix String
lit String
str)

  -- Stream the possible remainders after matching a wildcard followed by a literal.
  --
  -- NOTE: O( n * m ) where n = length str and m = length lit.
  skipWildcardLiteral :: String -> String -> [String]
  skipWildcardLiteral :: String -> String -> [String]
skipWildcardLiteral String
_lit [] = []
  skipWildcardLiteral String
lit str :: String
str@(Char
_c : String
str')
    -- NOTE: yield suff, but continue searching from str', in case of overlaps.
    | Just String
suff <- String -> String -> Maybe String
skipPrefix String
lit String
str = String
suff String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> String -> [String]
skipWildcardLiteral String
lit String
str'
    | Bool
otherwise = String -> String -> [String]
skipWildcardLiteral String
lit String
str'

  -- Stream the possible remainders after matching a literal.
  --
  -- NOTE: O( m ) where m = length lit
  skipPrefix :: String -> String -> Maybe String
  skipPrefix :: String -> String -> Maybe String
skipPrefix [] String
str = String -> Maybe String
forall a. a -> Maybe a
Just String
str
  skipPrefix (Char
_ : String
_) [] = Maybe String
forall a. Maybe a
Nothing
  skipPrefix (Char
l : String
lit') (Char
c : String
str') = if Char
l Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c then String -> String -> Maybe String
skipPrefix String
lit' String
str' else Maybe String
forall a. Maybe a
Nothing

-------------------------------------------------------------------------------
-- DList
-------------------------------------------------------------------------------

newtype DList a = MkDList {forall a. DList a -> [a] -> [a]
unDList :: [a] -> [a]}

instance Semigroup (DList a) where
  (<>) :: DList a -> DList a -> DList a
  MkDList [a] -> [a]
xs <> :: DList a -> DList a -> DList a
<> MkDList [a] -> [a]
ys = ([a] -> [a]) -> DList a
forall a. ([a] -> [a]) -> DList a
MkDList ([a] -> [a]
xs ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
ys)
  {-# INLINE (<>) #-}

instance Monoid (DList a) where
  mempty :: DList a
  mempty :: DList a
mempty = ([a] -> [a]) -> DList a
forall a. ([a] -> [a]) -> DList a
MkDList [a] -> [a]
forall a. a -> a
id
  {-# INLINE mempty #-}

instance IsList (DList a) where
  type Item (DList a) = a

  toList :: DList a -> [a]
  toList :: DList a -> [a]
toList = (([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ []) (([a] -> [a]) -> [a]) -> (DList a -> [a] -> [a]) -> DList a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DList a -> [a] -> [a]
forall a. DList a -> [a] -> [a]
unDList
  {-# INLINE toList #-}

  fromList :: [a] -> DList a
  fromList :: [a] -> DList a
fromList = ([a] -> [a]) -> DList a
forall a. ([a] -> [a]) -> DList a
MkDList (([a] -> [a]) -> DList a) -> ([a] -> [a] -> [a]) -> [a] -> DList a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)
  {-# INLINE fromList #-}

-------------------------------------------------------------------------------
-- WriterT
-------------------------------------------------------------------------------

newtype WriterT w m a = WriterT {forall w (m :: * -> *) a. WriterT w m a -> w -> m (a, w)
unWriterT :: w -> m (a, w)}

instance (Functor m) => Functor (WriterT w m) where
  fmap :: (Functor m) => (a -> b) -> WriterT w m a -> WriterT w m b
  fmap :: forall a b. Functor m => (a -> b) -> WriterT w m a -> WriterT w m b
fmap a -> b
f WriterT w m a
m = (w -> m (b, w)) -> WriterT w m b
forall w (m :: * -> *) a. (w -> m (a, w)) -> WriterT w m a
WriterT ((w -> m (b, w)) -> WriterT w m b)
-> (w -> m (b, w)) -> WriterT w m b
forall a b. (a -> b) -> a -> b
$ \w
w -> (\(a
a, w
w') -> (a -> b
f a
a, w
w')) ((a, w) -> (b, w)) -> m (a, w) -> m (b, w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> w -> m (a, w)
unWriterT WriterT w m a
m w
w
  {-# INLINE fmap #-}

instance (Functor m, Monad m) => Applicative (WriterT w m) where
  pure ::
    (Functor m, Monad m) =>
    a -> WriterT w m a
  pure :: forall a. (Functor m, Monad m) => a -> WriterT w m a
pure a
a = (w -> m (a, w)) -> WriterT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> WriterT w m a
WriterT ((w -> m (a, w)) -> WriterT w m a)
-> (w -> m (a, w)) -> WriterT w m a
forall a b. (a -> b) -> a -> b
$ \w
w -> (a, w) -> m (a, w)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, w
w)
  {-# INLINE pure #-}

  (<*>) ::
    (Functor m, Monad m) =>
    WriterT w m (a -> b) -> WriterT w m a -> WriterT w m b
  WriterT w -> m (a -> b, w)
mf <*> :: forall a b.
(Functor m, Monad m) =>
WriterT w m (a -> b) -> WriterT w m a -> WriterT w m b
<*> WriterT w -> m (a, w)
mx = (w -> m (b, w)) -> WriterT w m b
forall w (m :: * -> *) a. (w -> m (a, w)) -> WriterT w m a
WriterT ((w -> m (b, w)) -> WriterT w m b)
-> (w -> m (b, w)) -> WriterT w m b
forall a b. (a -> b) -> a -> b
$ \w
w -> do
    (f, w') <- w -> m (a -> b, w)
mf w
w
    (x, w'') <- mx w'
    return (f x, w'')
  {-# INLINE (<*>) #-}

instance (Monad m) => Monad (WriterT w m) where
  (>>=) ::
    (Monad m) =>
    WriterT w m a -> (a -> WriterT w m b) -> WriterT w m b
  WriterT w m a
m >>= :: forall a b.
Monad m =>
WriterT w m a -> (a -> WriterT w m b) -> WriterT w m b
>>= a -> WriterT w m b
k = (w -> m (b, w)) -> WriterT w m b
forall w (m :: * -> *) a. (w -> m (a, w)) -> WriterT w m a
WriterT ((w -> m (b, w)) -> WriterT w m b)
-> (w -> m (b, w)) -> WriterT w m b
forall a b. (a -> b) -> a -> b
$ \w
w -> do
    (a, w') <- WriterT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> w -> m (a, w)
unWriterT WriterT w m a
m w
w
    unWriterT (k a) w'
  {-# INLINE (>>=) #-}

writer :: (Monoid w, Monad m) => (a, w) -> WriterT w m a
writer :: forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
(a, w) -> WriterT w m a
writer (a
a, w
w') = (w -> m (a, w)) -> WriterT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> WriterT w m a
WriterT ((w -> m (a, w)) -> WriterT w m a)
-> (w -> m (a, w)) -> WriterT w m a
forall a b. (a -> b) -> a -> b
$ \w
w ->
  let wt :: w
wt = w
w w -> w -> w
forall a. Monoid a => a -> a -> a
`mappend` w
w' in w
wt w -> m (a, w) -> m (a, w)
forall a b. a -> b -> b
`seq` (a, w) -> m (a, w)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, w
wt)
{-# INLINE writer #-}

tell :: (Monoid w, Monad m) => w -> WriterT w m ()
tell :: forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell w
w = ((), w) -> WriterT w m ()
forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
(a, w) -> WriterT w m a
writer ((), w
w)
{-# INLINE tell #-}

runWriterT :: (Monoid w) => WriterT w m a -> m (a, w)
runWriterT :: forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT WriterT w m a
m = WriterT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> w -> m (a, w)
unWriterT WriterT w m a
m w
forall a. Monoid a => a
mempty
{-# INLINE runWriterT #-}

lift :: (Monad m) => m a -> WriterT w m a
lift :: forall (m :: * -> *) a w. Monad m => m a -> WriterT w m a
lift m a
m = (w -> m (a, w)) -> WriterT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> WriterT w m a
WriterT ((w -> m (a, w)) -> WriterT w m a)
-> (w -> m (a, w)) -> WriterT w m a
forall a b. (a -> b) -> a -> b
$ \w
w -> do
  a <- m a
m
  return (a, w)
{-# INLINE lift #-}

instance (MonadIO m) => MonadIO (WriterT w m) where
  liftIO :: (MonadIO m) => IO a -> WriterT w m a
  liftIO :: forall a. MonadIO m => IO a -> WriterT w m a
liftIO = m a -> WriterT w m a
forall (m :: * -> *) a w. Monad m => m a -> WriterT w m a
lift (m a -> WriterT w m a) -> (IO a -> m a) -> IO a -> WriterT w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
  {-# INLINE liftIO #-}