packages feed

fb-util (empty) → 0.1.0.1

raw patch · 148 files changed

+15164/−0 lines, 148 filesdep +HUnitdep +QuickCheckdep +aeson

Dependencies added: HUnit, QuickCheck, aeson, aeson-pretty, array, async, atomic-primops, attoparsec, attoparsec-aeson, base, binary, bytestring, bytestring-lexing, clock, concurrent-extra, containers, data-default, deepseq, directory, either, exceptions, extra, fb-stubs, fb-util, filepath, ghc, ghci, hashable, haskell-src-exts, hspec, hspec-contrib, integer-gmp, json, lens, lifted-base, mangle, monad-control, mtl, optparse-applicative, pretty, prettyprinter, primitive, process, regex-base, regex-pcre, scientific, some, split, stm, template-haskell, temporary, text, text-show, time, transformers, unix, unordered-containers, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,9 @@+# Revision history for fb-util++## 0.1.0.1 -- YYYY-mm-dd++* Builds with GHC 9.8.x++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ Compat/Prettyprinter.hs view
@@ -0,0 +1,16 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}+-- | Just a compat layer to avoid CPP when using prettyprinter+{-# LANGUAGE CPP #-}+module Compat.Prettyprinter (module P) where++#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter as P+#else+import Data.Text.Prettyprint.Doc as P+#endif
+ Compat/Prettyprinter/Render/Text.hs view
@@ -0,0 +1,16 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}+-- | Just a compat layer to avoid CPP when using prettyprinter+{-# LANGUAGE CPP #-}+module Compat.Prettyprinter.Render.Text (module P) where++#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter.Render.Text as P+#else+import Data.Text.Prettyprint.Doc.Render.Text as P+#endif
+ Compat/Prettyprinter/Util.hs view
@@ -0,0 +1,16 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}+-- | Just a compat layer to avoid CPP when using prettyprinter+{-# LANGUAGE CPP #-}+module Compat.Prettyprinter.Util (module P) where++#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter.Util as P+#else+import Data.Text.Prettyprint.Doc.Util as P+#endif
+ Control/Concurrent/Stream.hs view
@@ -0,0 +1,162 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++-- | Higher level concurrency facilities for multiple workers concurrently+-- over a streaming source of input++module Control.Concurrent.Stream+  ( stream+  , streamBound+  , streamWithState+  , streamWithResourceBound+  , mapConcurrently_unordered+  , forConcurrently_unordered+  ) where++import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception+import Control.Monad++import Util.Control.Exception+import Util.Log+import Data.IORef+import Data.IORef.Extra++data ShouldBindThreads = BoundThreads | UnboundThreads++data ShouldThrow = ThrowExceptions | SwallowExceptions++-- | Maps workers concurrently over a stream of values with a bounded size+--+-- Runs the producer until it terminates, passing in a function to add things+-- into the stream. Runs at most `maxConcurrency` threads simultaneously to+-- process things put into the stream.+-- There's no end aggregation for the output from each worker, which doesn't+-- make this composable. We can add that in the future when needed.+--+-- If a worker throws a synchronous exception, it will be+-- propagated to the caller.+--+-- `conduit` and `pipes` provide functionality for running consecutive stages+-- in parallel, but nothing for running a single stage concurrently.+stream+  :: Int -- ^ Maximum Concurrency+  -> ((a -> IO ()) -> IO ()) -- ^ Producer+  -> (a -> IO ()) -- ^ Worker+  -> IO ()+stream maxConcurrency producer worker =+  streamWithState producer (replicate maxConcurrency ()) $ const worker++-- | Like stream, but uses bound threads for the workers.  See+-- 'Control.Concurrent.forkOS' for details on bound threads.+streamBound+  :: Int -- ^ Maximum Concurrency+  -> ((a -> IO ()) -> IO ()) -- ^ Producer+  -> (a -> IO ()) -- ^ Worker+  -> IO ()+streamBound maxConcurrency producer worker =+  streamWithResourceBound maxConcurrency ($ ()) producer $ const worker++-- | Like stream, but each worker keeps a state: the state can be a parameter+-- to the worker function, or a state that you can build upon (for example the+-- state can be an IORef of some sort)+-- There will be a thread per worker state+streamWithState+  :: ((a -> IO ()) -> IO ()) -- ^ Producer+  -> [b] -- ^ Worker state+  -> (b -> a -> IO ()) -- ^ Worker+  -> IO ()+streamWithState producer states worker = stream_ UnboundThreads ThrowExceptions+  ($ ()) producer states (const worker)++-- | Like streamWithState but uses bound threads for the workers.+streamWithResourceBound+  :: Int  -- ^ Maximum concurrency+  -> ((resource -> IO ()) -> IO ()) -- ^ Worker resource acquisition, per thread+  -> ((a -> IO ()) -> IO ()) -- ^ Producer+  -> (resource -> a -> IO ()) -- ^ Worker+  -> IO ()+streamWithResourceBound maxConcurrency withResource producer worker =+  stream_ BoundThreads ThrowExceptions+    withResource producer (replicate maxConcurrency ()) (\r _ -> worker r)++stream_+  :: ShouldBindThreads -- use bound threads?+  -> ShouldThrow -- propagate worker exceptions?+  -> ((resource -> IO ()) -> IO ()) -- ^ resource acquisition+  -> ((a -> IO ()) -> IO ()) -- ^ Producer+  -> [b] -- Worker state+  -> (resource -> b -> a -> IO ()) -- ^ Worker+  -> IO ()+stream_ useBoundThreads shouldThrow withResource producer workerStates worker+  = do+  let maxConcurrency = length workerStates+  q <- atomically $ newTBQueue (fromIntegral maxConcurrency)+  let write x = atomically $ writeTBQueue q (Just x)+  mask $ \unmask ->+    concurrently_ (runWorkers unmask q) $ unmask $ do+      -- run the producer+      producer write+      -- write end-markers for all workers+      replicateM_ maxConcurrency $+        atomically $ writeTBQueue q Nothing+  where+    runWorkers unmask q = case useBoundThreads of+      BoundThreads ->+        foldr1 concurrentlyBound $+          map (withResource . runWorker unmask q) workerStates+      UnboundThreads ->+        mapConcurrently_ (withResource . runWorker unmask q) workerStates++    concurrentlyBound l r =+      withAsyncBound l $ \a ->+      withAsyncBound r $ \b ->+      void $ waitBoth a b++    runWorker unmask q s resource = do+      v <- atomically $ readTBQueue q+      case v of+        Nothing -> return ()+        Just t -> do+          e <- tryAll $ unmask $ worker resource s t+          case e of+            Left ex -> case shouldThrow of+              ThrowExceptions -> throw ex+              SwallowExceptions -> logError $ show ex+            Right _ -> return ()+          runWorker unmask q s resource++-- | Concurrent map over a stream of values. Results are unordered.+--+-- Convenience interface over Control.Concurrent.Stream (stream),+-- for processing values in lists in the same manner as mapConcurrently.+-- The list of output values may not be in the same order as the list+-- of input values.+mapConcurrently_unordered+  :: Int -- ^ Maximum concurrency+  -> (a -> IO b) -- ^ Function to map over the input values+  -> [a] -- ^ List of input values+  -> IO [b] -- ^ List of output values (unordered)+mapConcurrently_unordered maxConcurrency transformIO input = do+  outputRef <- Data.IORef.newIORef []+  stream maxConcurrency (forM_ input) $ \inputElement -> do+    transformedElement <- transformIO inputElement+    Data.IORef.Extra.atomicModifyIORef_ outputRef (transformedElement:)+  Data.IORef.readIORef outputRef++-- | Control.Concurrent.Stream (mapConcurrently) but with its arguments reversed+--+-- The list of output values may not be in the same order as the list+-- of input values.+forConcurrently_unordered+  :: Int -- ^ Maximum concurrency+  -> [a] -- ^ List of input values+  -> (a -> IO b) -- ^ Function to map over the input values+  -> IO [b] -- ^ List of output values (unordered)+forConcurrently_unordered = flip . mapConcurrently_unordered
+ Control/Trace.hs view
@@ -0,0 +1,36 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++-- | A tracing library inspired by dcoutts Contravariant logging talk[1]+--   and the co-log package.+--+--   [1] -  https://www.youtube.com/watch?v=qzOQOmmkKEM+--+--  Example of usage:+--+--  > tracer :: Tracer Text+--  > tracer = vlogTextTracer 1+--  >+--  > main = traceMsg tracer "main" $ do+--  >   putStrLn "Hello world"+--+module Control.Trace+  ( Tracer+  , logMsg+  , traceMsg+  , traceIf+  , (>$<)+  , vlogTracer+  , vlogTracerWithPriority+  , TraceWithPriority(..)+  , vlogShowTracer+  , vlogTextTracer+  ) where++import Control.Trace.Core+import Control.Trace.VLog
+ Control/Trace/Core.hs view
@@ -0,0 +1,113 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# OPTIONS -Wno-orphans #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE InstanceSigs #-}+module Control.Trace.Core (+  Tracer (..),+  MonadTrace (..),+  MonadMaskInstance (..),+  logMsg,+  traceMsg,+  traceIf,+  Contravariant,+  (>$<),+) where++import Control.Monad (when)+import Control.Monad.Catch (+  ExitCase (..),+  MonadCatch,+  MonadMask (generalBracket),+  MonadThrow,+ )+import Control.Monad.IO.Class (+  MonadIO (..),+ )+import Data.Coerce+import Data.Functor.Contravariant (+  Contravariant (contramap),+  (>$<),+ )+import GHC.Stack (+  HasCallStack,+  withFrozenCallStack,+ )++-- | A contravariant tracing abstraction+data Tracer msg = Tracer+  { -- | Log a message+    logMsg_ :: msg -> IO ()+  , -- | Starts a trace and returns an action to end it+    traceMsg_+      :: forall a. HasCallStack => msg -> IO (ExitCase a -> IO ())+  }++logMsg :: (HasCallStack, MonadIO m) => Tracer msg -> msg -> m ()+logMsg logger msg = withFrozenCallStack $ liftIO $ logMsg_ logger msg++traceMsg ::+  (HasCallStack, MonadTrace m) => Tracer msg -> msg -> m a -> m a+traceMsg logger msg act = withFrozenCallStack $+  bracketM (traceMsg_ logger msg) id (const act)++instance Contravariant Tracer where+  contramap f (Tracer logf traceF) = Tracer (logf . f) (traceF . f)++instance Monoid (Tracer msg) where+  mempty = Tracer (\_ -> pure ()) (const $ pure $ const $ pure ())++instance Semigroup (Tracer msg) where+  l1 <> l2 =+    Tracer+      { logMsg_ = \m -> logMsg_ l1 m *> logMsg_ l2 m+      , traceMsg_ = \msg -> do+        end1 <- traceMsg_ l1 msg+        end2 <- traceMsg_ l2 msg+        return (\res -> end2 res >> end1 res)+      }++--------------------------------------------------------------------------------+-- useful combinators++-- | Gate every trace behind a condition+traceIf :: forall msg. IO Bool -> Tracer msg -> Tracer msg+traceIf cond tracer =+  let+    logMsg' msg = do+      value <- cond+      when value $ logMsg_ tracer msg+    traceMsg' :: msg -> IO (ExitCase b -> IO ())+    traceMsg' msg = do+      value <- cond+      if value+        then traceMsg_ tracer msg+        else pure $ pure $ pure ()+  in Tracer logMsg' traceMsg'++--------------------------------------------------------------------------------+-- A Monad for 'bracket'++class MonadIO m => MonadTrace m where+  bracketM :: IO a -> (a -> ExitCase b -> IO ()) -> (a -> m b) -> m b++-- deriving via (MonadMaskInstance IO) instance MonadTrace IO+instance MonadTrace IO where+  bracketM+    :: forall a b . IO a -> (a -> ExitCase b -> IO ()) -> (a -> IO b) -> IO b+  bracketM = coerce (bracketM @(MonadMaskInstance IO) @a @b)++-- | Deriving 'MonadTrace' via 'MonadMask'+newtype MonadMaskInstance m a = MonadMaskInstance (m a)+  deriving+    (Applicative, Functor, Monad, MonadCatch, MonadIO, MonadMask, MonadThrow)++instance (MonadIO m, MonadMask m) => MonadTrace (MonadMaskInstance m) where+  bracketM acquire release =+    fmap fst . generalBracket (liftIO acquire) ((liftIO .) . release)
+ Control/Trace/VLog.hs view
@@ -0,0 +1,114 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE ViewPatterns, CPP #-}+module Control.Trace.VLog (+  vlogTracer,+  TraceWithPriority (..),+  vlogTracerWithPriority,+  vlogShowTracer,+  vlogTextTracer,+) where++import Control.Monad (when)+import Control.Monad.Catch (+  ExitCase (+    ExitCaseAbort,+    ExitCaseException,+    ExitCaseSuccess+  ),+ )+import Control.Monad.IO.Class+import Control.Trace.Core+import Data.Some+import Data.Text (Text)+import GHC.Stack+import TextShow (+  TextShow,+  showt,+ )+import qualified Util.Log.String as String+import Util.Log.Text++vlogShowTracer :: TextShow a => (a -> Int) -> Tracer a+vlogShowTracer =+  vlogTracer+    (\(showt -> x) -> ("BEGIN " <> x, \e -> "END" <> renderExitCase e <> x))+    showt++renderExitCase :: Some ExitCase -> Text+renderExitCase (Some ExitCaseAbort {}) = "(aborted) "+renderExitCase (Some (ExitCaseException e)) = "(" <> showt e <> ") "+renderExitCase (Some ExitCaseSuccess {}) = " "++vlogTextTracer :: Int -> Tracer Text+vlogTextTracer p =+  vlogTracer+    (\x -> ("BEGIN " <> x, \e -> "END" <> renderExitCase e <> x))+    id+    (const p)++data TraceWithPriority+  = Skip+  | T !Int !Text+  | S !Int !String++vlogTracerWithPriority :: Tracer TraceWithPriority+vlogTracerWithPriority = Tracer {..}+  where+    logMsg_ :: (HasCallStack, MonadIO m) => TraceWithPriority -> m ()+    logMsg_ Skip = pure ()+    logMsg_ x = withFrozenCallStack $ case x of+      T p t -> vlog p t+      S p s -> String.vlog p s+#if __GLASGOW_HASKELL__ < 902+      Skip -> error "unreachable"+#endif++    traceMsg_ msg =+      case msg of+        T p t -> do+            vlog p ("BEGIN " <> t)+            return ( \res -> case res of+                ExitCaseSuccess {} -> vlog p ("END " <> t)+                ExitCaseAbort {} -> vlog p ("ABORTED " <> t)+                ExitCaseException e -> vlog p ("FAILED " <> t <> ": " <> showt e)+              )+        S p t -> do+            String.vlog p ("BEGIN " <> t)+            return ( \res -> case res of+                ExitCaseSuccess {} -> String.vlog p ("END " <> t)+                ExitCaseAbort {} -> String.vlog p ("ABORTED " <> t)+                ExitCaseException e ->+                  String.vlog p ("FAILED " <> t <> ": " <> show e)+              )+        Skip -> return $ const $ return ()++vlogTracer ::+  forall a.+  -- | render BEGIN and END messages+  (a -> (Text, Some ExitCase -> Text)) ->+  -- | render LOG message+  (a -> Text) ->+  -- | Priority (use -1 to skip)+  (a -> Int) ->+  Tracer a+vlogTracer beginend log_ prio = Tracer {..}+  where+    logMsg_ :: a -> IO ()+    logMsg_ msg =+        let p = prio msg+         in when (p >= 0) $ vlog p $ log_ msg++    traceMsg_ :: a -> IO (ExitCase b -> IO ())+    traceMsg_ msg = do+      let p = prio msg+          (b, e) = beginend msg+      if p >= 0+        then vlog p b >> return (\res -> vlog p (e $ mkSome res))+        else return $ const $ return ()
+ Data/MovingAverageRateLimiter.hs view
@@ -0,0 +1,105 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{- |+A standalone rate limiter that accepts some fluctuations in the traffic.++QPS_new = QPS_old * exp(-alpha * t) + n * alpha+where alpha is the decay factor, t is the time elapsed and n is the number of+new requests (that are allowed).++See also www/flib/social/ma_rate_limiter/MovingAverageRateLimiter.php+and fbcode/common/datastruct/MovingAverageRateLimiter.h+-}++module Data.MovingAverageRateLimiter+  ( RateLimiterConfig(qpsLimit, decayHalfLife)+  , mkRateLimiterConfig+  , RateLimiter(qps)+  , mkRateLimiter+  , updateConfig+  , observedRate+  , allow+  ) where++-- ----------------------------------------------------------------------------++data RateLimiterConfig = RateLimiterConfig+  { qpsLimit      :: {-# UNPACK #-} !Double  -- ^ Query per second limit+  , decayHalfLife :: {-# UNPACK #-} !Double+  -- ^ Time in seconds for the weight of past query to decay to half+  -- in moving average calculation+  , alpha         :: {-# UNPACK #-} !Double+  }++mkRateLimiterConfig+  :: Double  -- ^ query per second limit+  -> Double  -- ^ decay half life+  -> RateLimiterConfig+mkRateLimiterConfig ql d = RateLimiterConfig+  { qpsLimit = ql+  , decayHalfLife = d+  , alpha = log 2.0 / d+  }++updateConfig+  :: Double  -- ^ new query per second limit+  -> Double  -- ^ new decay half life+  -> RateLimiterConfig -> RateLimiterConfig+updateConfig ql d r = r+  { qpsLimit = ql+  , decayHalfLife = d+  , alpha = log 2.0 / d+  }++-- ----------------------------------------------------------------------------++data RateLimiter = RateLimiter+  { qps           :: {-# UNPACK #-} !Double+  , lastTimestamp :: {-# UNPACK #-} !Double  -- in sec+  }++mkRateLimiter :: RateLimiter+mkRateLimiter = RateLimiter+  { qps = 0+  , lastTimestamp = 0+  }++observedRate+  :: RateLimiter+  -> Double      -- ^ queries per second+  -> Double      -- ^ timestamp of the last query+  -> RateLimiter+observedRate r q t = r+  { qps = q+  , lastTimestamp = t+  }++allow+  :: RateLimiterConfig+  -> RateLimiter+  -> Double               -- ^ current timestamp+  -> (Bool, RateLimiter)  -- ^ should the query is allowed? and the new state+allow RateLimiterConfig{..} r@RateLimiter{..} t = (a, observedRate r q2 t)+  where+  timeDiff = t - lastTimestamp+  q1 = if timeDiff > 0 then qps * exp (- alpha * timeDiff) else qps+  (a, q2) | lastTimestamp == 0 = (True , qpsLimit * (1 - alpha) + alpha)+                                   -- See Note [First Bump]+          | q1 < qpsLimit      = (True , q1 + alpha)+          | otherwise          = (False, q1)++-- Note [First Bump]+-- If the lastTimestamp is zero, this is the first time a RateLimiter has been+-- bumped. In that case, always allow, then set the qps to the qpsLimit minus+-- enough room for (qpsLimit - 1) additional bumps. This means the RateLimiter+-- will allow qpsLimit bumps at time zero, then throttle at bump qpsLimit + 1.+-- Without this, time is required for the count to approach the decay rate,+-- resulting in an initial spike of allowed bumps. For example, a RateLimiter+-- configured to 1 qps with 600 s half-life would allow at least the first+-- 865 bumps before actually limiting.
+ Data/RateLimiterMap.hs view
@@ -0,0 +1,167 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE CPP #-}+module Data.RateLimiterMap+  ( -- * RateLimiterMap+    RateLimiterMap+  , newRateLimiterMap+  , newRateLimiterMapWithKeyPreprocessor+  , updateRateLimiterMapConfig+  , rateLimitFilter+  , whenAllowed+    -- * Types+  , Allowed(..)+  , SampleWeight+    -- * Primitives+  , isAllowed+  ) where++import Data.Hashable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.IORef+import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.Atomics++import Data.MovingAverageRateLimiter++type Count = Int+type SampleWeight = Int++-- | A 'RateLimiterMap' implements per-key rate limiting using+-- 'MovingAverageRateLimiter'. It is intentionally kept abstract.+data RateLimiterMap k = RateLimiterMap+  { rlmRef    :: {-# UNPACK #-} !(IORef (HashMap k (IORef RateLimitWithCount)))+  , rlmConfig :: {-# UNPACK #-} !(IORef RateLimiterConfig)+  , rlmKeyPreprocessor :: !(k -> IO k)+  }++-- Essentially a more strict and unboxed tuple.+data RateLimitWithCount = RateLimitWithCount {-# UNPACK #-} !Count !RateLimiter++-- | Indicates whether key is rate-limited.+-- 'Allowed' carries a weight, which is the number of calls to+-- 'isAllowed' since the last time 'Allowed' was returned.+data Allowed = NotAllowed | Allowed {-# UNPACK #-} !SampleWeight++-- | Create a new RateLimiterMap.+newRateLimiterMap+  :: Double                 -- ^ QPS Limit+  -> Double                 -- ^ Decay half-life, in seconds+  -> IO (RateLimiterMap k)+newRateLimiterMap lim hl = newRateLimiterMapWithKeyPreprocessor lim hl return++-- | Create a new RateLimiterMap with a preprocess provided, this preprocessor+-- is invoked before a key is inserted in the map. This may be needed in certain+-- scenarios when certain transformations need to be done on the keys before+-- they are inserted.+newRateLimiterMapWithKeyPreprocessor+  :: Double                 -- ^ QPS Limit+  -> Double                 -- ^ Decay half-life, in seconds+  -> (k -> IO k)      -- ^ Key preprocessor+  -> IO (RateLimiterMap k)+newRateLimiterMapWithKeyPreprocessor lim hl keyPreprocessor = do+  ref <- newIORef HashMap.empty+  cfgRef <- newIORef $ mkRateLimiterConfig lim hl+  return $ RateLimiterMap ref cfgRef keyPreprocessor++-- | Change the configuration of a 'RateLimiterMap'.+-- This DOES NOT change the internal state of individual limiters.+-- It only changes the qps limit and decay rate that will be applied+-- to future rate-limit checks.+updateRateLimiterMapConfig+  :: RateLimiterMap k+  -> (RateLimiterConfig -> RateLimiterConfig)+  -> IO ()+updateRateLimiterMapConfig RateLimiterMap{..} f =+  atomicModifyIORefCAS rlmConfig (\ c -> (f c, ()))++-- | Rate-limit an action.+-- This is the preferred means of using a 'RateLimiterMap'.+whenAllowed+  :: (Eq k, Hashable k)+  => RateLimiterMap k+  -> k+  -> (SampleWeight -> IO ()) -- ^ If allowed, run this action+  -> IO ()+whenAllowed rlm k f = do+  allowed <- isAllowed rlm k+  case allowed of+    NotAllowed -> return ()+    Allowed sw -> f sw++-- | Filter association list by rate limiter.+-- Return all values whose keys pass the rate limiter.+rateLimitFilter+  :: (Eq k, Hashable k)+  => RateLimiterMap k+  -> [(k, v)]+  -> IO [(SampleWeight, v)]+rateLimitFilter rlm = go+  where go []            = return []+        go ((k, v):kvs) = do+          allowed <- isAllowed rlm k+          case allowed of+            NotAllowed ->                 go kvs+            Allowed sw -> ((sw, v) :) <$> go kvs++-- | Determine whether a new action is allowed by the 'RateLimiterMap'.+-- This check is *not* idempotent (it bumps the rate-limit counter).+-- The preferred means to rate-limit an action is with 'whenAllowed'.+isAllowed :: (Eq k, Hashable k) => RateLimiterMap k -> k -> IO Allowed+isAllowed RateLimiterMap{..} k = do+  mbRL <- HashMap.lookup k <$> readIORef rlmRef+  cfg <- readIORef rlmConfig+  case mbRL of+    Just ref -> allowCheck cfg ref+    Nothing -> do+      -- Key hasn't been seen, create a new IORef for it.+      newRef <- newIORef $ RateLimitWithCount 0 mkRateLimiter+      newKey <- rlmKeyPreprocessor k+      -- Associate the IORef with the key. If its been added by+      -- another thread, return that IORef instead.+      newRef' <- atomicModifyIORefCAS rlmRef $ addOrReturnExisting newKey newRef+      allowCheck cfg newRef'++-- ----------------------------------------------------------------------------+-- Internals++-- | Run 'mutate' with the current time.+allowCheck :: RateLimiterConfig -> IORef RateLimitWithCount -> IO Allowed+allowCheck cfg rlRef = do+  t <- realToFrac <$> getPOSIXTime+  atomicModifyIORefCAS rlRef (mutate cfg t)++-- | Wrapper around MovingAverageRateLimiter's 'allow' which also counts+-- how many times the check has been performed. This count is used as the+-- sample weight whenever 'Allowed' is returned.+mutate+  :: RateLimiterConfig+  -> Double             -- ^ current timestamp+  -> RateLimitWithCount+  -> (RateLimitWithCount, Allowed)+mutate cfg t (RateLimitWithCount c rl) =+  case allow cfg rl t of+    (True , rl') -> (RateLimitWithCount 0     rl', Allowed (c+1))+    (False, rl') -> (RateLimitWithCount (c+1) rl', NotAllowed)++-- | Meant to be called inside atomicModifyIORef. Attempts to insert into+-- the HashMap, but if the key is already set, returns the existing value+-- instead. This way several threads can race-to-insert, one will win,+-- and the rest will get a copy of the winner's value.+addOrReturnExisting+  :: (Eq k, Hashable k)+  => k+  -> a+  -> HashMap k a+  -> (HashMap k a, a)+addOrReturnExisting k v m =+  case HashMap.lookup k m of+    Just v' -> (m, v')+    Nothing -> (HashMap.insert k v m, v)
+ Foreign/CPP/Addressable.hs view
@@ -0,0 +1,107 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE DefaultSignatures #-}+module Foreign.CPP.Addressable+  ( Addressable(..)+  , Addressable1(..)+  ) where++import Data.Complex (Complex)+import Data.Ratio (Ratio)+import Data.Functor.Const (Const)+import Data.Functor.Identity (Identity)+import Foreign hiding (sizeOf, alignment)+import Foreign.C.Types+import qualified Foreign.Storable as Storable+import GHC.Fingerprint (Fingerprint)+import System.Posix.Types++class Addressable a where+  -- | Computes the storage requirements (in bytes) of the argument.+  -- The value of the argument is not used.+  sizeOf :: a -> Int+  default sizeOf :: Storable a => a -> Int+  sizeOf = Storable.sizeOf++  -- | Computes the alignment constraint of the argument. An alignment+  -- constraint @x@ is fulfilled by any address divisible by @x@.+  -- The value of the argument is not used.+  alignment :: a -> Int+  default alignment :: Storable a => a -> Int+  alignment = Storable.alignment++class Addressable1 f where+  sizeOf1 :: f a -> Int+  alignment1 :: f a -> Int++instance Addressable Bool+instance Addressable Char+instance Addressable Double+instance Addressable Float+instance Addressable Int+instance Addressable Int8+instance Addressable Int16+instance Addressable Int32+instance Addressable Int64+instance Addressable Word+instance Addressable Word8+instance Addressable Word16+instance Addressable Word32+instance Addressable Word64+instance Addressable ()+instance Addressable Fingerprint+instance Addressable CUIntMax+instance Addressable CIntMax+instance Addressable CUIntPtr+instance Addressable CIntPtr+instance Addressable CSUSeconds+instance Addressable CUSeconds+instance Addressable CTime+instance Addressable CClock+instance Addressable CSigAtomic+instance Addressable CWchar+instance Addressable CSize+instance Addressable CPtrdiff+instance Addressable CDouble+instance Addressable CFloat+instance Addressable CULLong+instance Addressable CLLong+instance Addressable CULong+instance Addressable CLong+instance Addressable CUInt+instance Addressable CInt+instance Addressable CUShort+instance Addressable CShort+instance Addressable CUChar+instance Addressable CSChar+instance Addressable CChar+instance Addressable CBool+instance Addressable IntPtr+instance Addressable WordPtr+instance Addressable Fd+instance Addressable CRLim+instance Addressable CTcflag+instance Addressable CSpeed+instance Addressable CCc+instance Addressable CUid+instance Addressable CNlink+instance Addressable CGid+instance Addressable CSsize+instance Addressable CPid+instance Addressable COff+instance Addressable CMode+instance Addressable CIno+instance Addressable CDev+instance (Storable a, Integral a) => Addressable (Ratio a)+instance Addressable (StablePtr a)+instance Addressable (Ptr a)+instance Addressable (FunPtr a)+instance Storable a => Addressable (Complex a)+instance Storable a => Addressable (Identity a)+instance Storable a => Addressable (Const a b)
+ Foreign/CPP/Dynamic.hsc view
@@ -0,0 +1,332 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++--+-- Marshal folly::dynamic directly into Haskell's Data.Aeson,+-- and in the other direction.+--++{-# LANGUAGE TemplateHaskell, QuasiQuotes, DeriveGeneric #-}++{-# OPTIONS -fno-warn-unused-imports #-} -- broken on this module+module Foreign.CPP.Dynamic+  ( Dynamic+  , readDynamic+  , readDynamicLenient+  , createDynamic+  , destroyDynamic+  , withDynamic+  , parseJSON+  , parseJSONWithOptions+  , JSONOptions(..)+  , JSONParserFFI+  , callJSONParserFFI+  ) where++import Control.Monad (when)+import Data.ByteString (ByteString)+import Data.ByteString.Unsafe+import Data.Default+import qualified Data.ByteString as B+import Foreign.C+import Foreign hiding (alloca, allocaBytes, allocaArray)+-- Custom alloca and friends+import Util.Memory+import Util.ByteString+import GHC.Generics+import Data.Coerce++import Control.Applicative ((<$>))+import Control.Exception (bracket)+import Data.Aeson hiding (parseJSON)+import qualified Data.Vector as Vector+import qualified Data.HashMap.Strict as HashMap+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Scientific++import Mangle.TH+import Foreign.CPP.Marshallable.TH+import Util.Aeson+import Util.Text+  ( cStringToText+  , cStringToTextLenient+  , useTextAsCString+  , useTextsAsCStrings )+import Util.String.Quasi++-- | Phantom type for @folly::dynamic@ pointers.+newtype Dynamic = Dynamic+  { unDynamic :: Value }++$(deriveDestructibleUnsafe "Dynamic" [t| Dynamic |])++newtype DType = DType #{type DType}+  deriving (Eq, Storable)++#{enum DType, DType+  , tNull   = tNull+  , tArray  = tArray+  , tBool   = tBool+  , tDouble = tDouble+  , tInt64  = tInt64+  , tObject = tObject+  , tString = tString+  }++$(mangle+  [s|+    void facebook::hs::readDynamic(+        const folly::dynamic*, DType*, DValue*)+  |] [d|+    foreign import ccall unsafe+      c_readDynamic :: Ptr Dynamic -> Ptr DType -> Ptr () -> IO ()+  |])++$(mangle+  [s|+    int facebook::hs::readDynamicArray(+      const folly::dynamic*, size_t, const folly::dynamic**)+  |] [d|+    foreign import ccall unsafe+      c_readDynamicArray :: Ptr Dynamic -> CSize+                         -> Ptr (Ptr Dynamic)+                         -> IO CInt+  |])++$(mangle+  [s|+    int facebook::hs::readDynamicObject(+       const folly::dynamic*, size_t,+       const folly::dynamic**, const folly::dynamic**)+  |] [d|+    foreign import ccall unsafe+      c_readDynamicObject :: Ptr Dynamic -> CSize+                          -> Ptr (Ptr Dynamic)+                          -> Ptr (Ptr Dynamic)+                          -> IO CInt+  |])++$(mangle+  "void facebook::hs::createDynamic(folly::dynamic*, DType, DValue*)"+  [d|+    foreign import ccall unsafe+      c_createDynamic :: Ptr Dynamic -> DType -> Ptr () -> IO ()+  |])++$(mangle+  [s|+    void facebook::hs::createDynamicArray(+      folly::dynamic*, size_t, folly::dynamic*)+  |] [d|+    foreign import ccall unsafe+      c_createDynamicArray :: Ptr Dynamic -> CSize -> Ptr Dynamic -> IO ()+  |])++$(mangle+  [s|+    void facebook::hs::createDynamicObject(+      folly::dynamic*, size_t, const char**, folly::dynamic*)+  |] [d|+    foreign import ccall unsafe+      c_createDynamicObject :: Ptr Dynamic+                            -> CSize+                            -> Ptr CString+                            -> Ptr Dynamic+                            -> IO ()+  |])++$(mangle+  "folly::dynamic* facebook::hs::parseJSON(const char*, int64_t, int, char **)"+  [d|+    foreign import ccall unsafe+      c_parseJSON :: CString -> CLong -> CInt -> Ptr (Ptr CChar)+        -> IO (Ptr Dynamic)+  |])+++$(mangle+  "folly::dynamic* facebook::hs::parseJSON(const char*, int64_t, int, char **)"+  [d|+    foreign import ccall safe+      c_parseJSON_safe :: CString -> CLong -> CInt -> Ptr (Ptr CChar)+        -> IO (Ptr Dynamic)+  |])++-- | Reads a 'Dynamic' into an Aeson 'Value'.+--+-- Dynamic objects can have any type as the key, whereas JSON has only+-- string keys. This shows up when a PHP array has been converted to a+-- @folly::dynamic@, which will be an object with integer keys.+-- Therefore here we convert integer keys to strings to make it valid+-- JSON.+readDynamic :: Ptr Dynamic -> IO Value+readDynamic p = unDynamic <$> peek p++-- | Reads a 'Dynamic' into an Aeson 'Value' using lenient UTF-8 decoding.+readDynamicLenient :: Ptr Dynamic -> IO Value+readDynamicLenient p = unDynamic <$> peekImpl cStringToTextLenient p++-- | Creates a 'Dynamic' from an Aeson 'Value'.+--+-- Remember to call 'destroyDynamic' to free the memory.+createDynamic :: Value -> IO (Ptr Dynamic)+createDynamic v = new $ Dynamic v++-- | Frees the memory owned by 'Dynamic'+destroyDynamic :: Ptr Dynamic -> IO ()+destroyDynamic p = destruct p >> free p++-- | Executes an 'IO' action with an Aeson 'Value' marshalled as a 'Dynamic'+withDynamic :: Value -> (Ptr Dynamic -> IO a) -> IO a+withDynamic v = bracket (createDynamic v) destroyDynamic++newtype JSONOptions = JSONOptions+  { json_recursionLimit :: Maybe Int+  }+  deriving Generic++instance Default JSONOptions++-- | Parse JSON using folly::parseJson(), which is typically about 2x+-- faster than Aeson's family of JSON parsing functions.+parseJSON :: ByteString -> IO (Either Text Value)+parseJSON = parseJSONWithOptions def++type JSONParserFFI = CString -> CLong -> Ptr (Ptr CChar) -> IO (Ptr Dynamic)++parseJSONWithOptions :: JSONOptions -> ByteString -> IO (Either Text Value)+parseJSONWithOptions JSONOptions{..} bs = callJSONParserFFI parserFFI bs+  where+    rec = maybe (-1) fromIntegral json_recursionLimit+    parserFFI cstr clen = ffi cstr clen rec+    ffi+      -- conservative: 100K parses in about 0.2ms+      | B.length bs > 10*1024 = c_parseJSON_safe+      | otherwise = c_parseJSON++callJSONParserFFI :: JSONParserFFI -> ByteString -> IO (Either Text Value)+callJSONParserFFI ffi bs =+  unsafeUseAsCStringLen bs $ \(cstr, clen) ->+  Foreign.with nullPtr $ \perr -> do+    let+      cleanup pdynamic = do+        str <- peek perr+        when (str /= nullPtr) $ free str+        delete pdynamic+    bracket+      (ffi cstr (fromIntegral clen) perr)+      cleanup $ \pdynamic -> do+        if pdynamic == nullPtr+          then fmap Left $ cStringToText =<< peek perr+          else Right <$> readDynamic pdynamic++#include <cpp/cdynamic.h>++peekImpl :: (CString -> IO Text) -> Ptr Dynamic -> IO Dynamic+peekImpl peekCString p = do+  alloca $ \pty -> allocaBytes #{size DValue} $ \pval ->+    let getDyn pdyn = do+          c_readDynamic pdyn pty pval+          ty <- peek pty+          if+            | ty == tNull   -> return Null+            | ty == tArray  -> getDynArray pdyn+            | ty == tBool   -> do b <- peek (castPtr pval :: Ptr CInt)+                                  return (Bool (b /= 0))+            | ty == tDouble -> do d <- peek (castPtr pval :: Ptr Double)+                                  return (Number (fromFloatDigits d))+            | ty == tInt64  -> do i <- peek (castPtr pval :: Ptr Int64)+                                  return (Number (fromIntegral i))+            | ty == tString -> do s <- peek (castPtr pval :: Ptr CString)+                                  txt <- peekCString s+                                  return (String txt)+            | ty == tObject -> getDynObject pdyn+            | otherwise -> error "Foreign.CPP.Dynamic: illegal key type"++        getDynKey pdyn = do+          c_readDynamic pdyn pty pval+          ty <- peek pty+          if+            | ty == tDouble -> do d <- peek (castPtr pval :: Ptr Double)+                                  return $! Text.pack (show d)+            | ty == tInt64  -> do i <- peek (castPtr pval :: Ptr Int64)+                                  return $! Text.pack (show i)+            | ty == tString -> do s <- peek (castPtr pval :: Ptr CString)+                                  txt <- peekCString s+                                  return txt+            | otherwise -> error "Foreign.CPP.Dynamic: illegal key type"++        getDynArray pdyn = do+          size <- peek (castPtr pval :: Ptr CSize)+          allocaArray (fromIntegral size) $ \pelems -> do+            -- could be much more efficient here+            num <- c_readDynamicArray pdyn size pelems+            elems <- peekArray (fromIntegral num) pelems+            dyns <- mapM getDyn elems+            return (Array (Vector.fromList dyns))++        getDynObject pdyn = do+          size <- peek (castPtr pval :: Ptr CSize)+          allocaArray (fromIntegral size) $ \pkeys -> do+            allocaArray (fromIntegral size) $ \pvals -> do+              num <- c_readDynamicObject pdyn size pkeys pvals+              let+                  go !i !obj+                    | i >= fromIntegral num = return (Object obj)+                    | otherwise = do+                      key <- peekElemOff pkeys i >>= getDynKey+                      val <- peekElemOff pvals i >>= getDyn+                      go (i+1) (insertKeyMap (keyFromText key) val obj)++              go 0 emptyKeyMap+    in+    Dynamic <$> getDyn p++instance Storable Dynamic where+  sizeOf _ = #{size folly::dynamic}+  alignment _ = #{alignment folly::dynamic}++  peek = peekImpl cStringToText++  poke p v = do+    allocaBytes #{size DValue} $ \pval ->+      let putDyn' :: Storable a => Ptr Dynamic -> DType -> a -> IO ()+          putDyn' pdyn ty val = do+            poke (castPtr pval) val+            c_createDynamic pdyn ty pval++          putDyn pdyn Null = c_createDynamic pdyn tNull nullPtr++          putDyn pdyn (Bool b) = putDyn' pdyn tBool $ if b then 1 else 0 :: CInt++          putDyn pdyn (Number n) =+            case floatingOrInteger n of+              Left d -> putDyn' pdyn tDouble (d :: Double)+              Right i -> putDyn' pdyn tInt64 (i :: Int64)++          putDyn pdyn (String s) = useTextAsCString s $ putDyn' pdyn tString++          putDyn pdyn (Array arr) = do+            let size = Vector.length arr+            withArray' size (map Dynamic $ Vector.toList arr) $ \pelems ->+              c_createDynamicArray pdyn (fromIntegral $ size) pelems++          putDyn pdyn (Object obj) = do+            let size = keyMapSize obj+                (keys, vals) = unzip $ objectToList obj+            useTextsAsCStrings (map keyToText keys) $ \pkeys ->+              withArray' size (map Dynamic vals) $ \pvals ->+                c_createDynamicObject pdyn (fromIntegral $ size) pkeys pvals+      in+      putDyn p $ unDynamic v+    where+    withArray' n a f =+      allocaArray n $ \pa -> do+        pokeArray pa a+        f pa
+ Foreign/CPP/HsStruct.hs view
@@ -0,0 +1,19 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Foreign.CPP.HsStruct+  ( coerce+  , Addressable+  , module Types+  , module Utils+  ) where++import Data.Coerce+import Foreign.CPP.Addressable (Addressable)+import Foreign.CPP.HsStruct.Types as Types+import Foreign.CPP.HsStruct.Utils as Utils
+ Foreign/CPP/HsStruct/HsArray.hs view
@@ -0,0 +1,105 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE TemplateHaskell #-}+module Foreign.CPP.HsStruct.HsArray+  ( deriveHsArrayUnsafe+  ) where+++import Control.Monad (forM_)+import Data.Char (isAlphaNum)+import Data.Vector (forM_)+import Language.Haskell.TH++import Foreign+import Foreign.C.Types (CSize)+import Foreign.CPP.Marshallable+++deriveHsArrayUnsafe+  :: String -> TypeQ -> Q [Dec]+deriveHsArrayUnsafe cppType hsType = do+  arrayTypeStr <-+    map (\i -> if isAlphaNum i then i else '_') . pprint <$> arrayType++  let+    cppNewName = "vector_new" ++ cppName+    hsNewName = mkName $ "c_vector_new" ++ arrayTypeStr+  newImport <- forImpD cCall unsafe cppNewName hsNewName+      [t| CSize -> IO (Ptr ()) |]++  let+    cppConstructName = "vector_construct" ++ cppName+    hsConstructName = mkName $ "c_vector_construct" ++ arrayTypeStr+  constructImport <- forImpD cCall unsafe cppConstructName hsConstructName+      [t| Ptr () -> CSize -> IO () |]++  let+    cppAddName = "vector_add" ++ cppName+    hsAddName = mkName $ "c_vector_add" ++ arrayTypeStr+  addImport <- forImpD cCall unsafe cppAddName hsAddName+      [t| Ptr () -> Ptr $hsType -> IO () |]++  hsT <- hsType+  isDestructible <- isInstance (mkName "Destructible") [hsT]++  let+    withFn = mkName $ if isDestructible then "withCxxObject" else "with"++    pN = mkName "p"+    vsN = mkName "vs"+    fromIntegralChunk = [| fromIntegral (length vs) |]+    addChunk forMFn =+      [| $forMFn vs $ \v ->+           $(varE withFn) v $ \v_ptr ->+             $(varE hsAddName) (castPtr p) v_ptr+      |]++    newValueFn forMFn cType = funD (mkName "newValue")+      [clause [conP (mkName cType) [varP vsN]] (normalB $ doE+        [ bindS (varP pN)+            [| castPtr <$> $(varE hsNewName) $(fromIntegralChunk)|]+        , noBindS (addChunk forMFn)+        , noBindS [| return p |]+        ]) []]++    constructValueFn forMFn cType = funD (mkName "constructValue")+      [clause [varP pN, conP (mkName cType) [varP vsN]] (normalB $ doE+        [ noBindS [| $(varE hsConstructName) (castPtr p) $(fromIntegralChunk)|]+        , noBindS (addChunk forMFn)+        ]) []]+++  --  instance Constructible (HsList <TYPE>) where+  constructibleListInst <- instanceD+    (cxt [])+    [t| Constructible $listType |]+    [ newValueFn [| Control.Monad.forM_ |] "HsList"+    , constructValueFn [| Control.Monad.forM_ |] "HsList"+    ]++  --  instance Constructible (HsArray <TYPE>) where+  constructibleArrayInst <- instanceD+    (cxt [])+    [t| Constructible $arrayType |]+    [ newValueFn [| Data.Vector.forM_ |] "HsArray"+    , constructValueFn [| Data.Vector.forM_ |] "HsArray"+    ]++  return+    [ constructibleListInst+    , constructibleArrayInst+    , newImport+    , constructImport+    , addImport+    ]+  where+    listType = conT (mkName "HsList") `appT` hsType+    arrayType = conT (mkName "HsArray") `appT` hsType+    cppName = "HsArray" ++ cppType
+ Foreign/CPP/HsStruct/HsMap.hs view
@@ -0,0 +1,121 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE TemplateHaskell #-}++module Foreign.CPP.HsStruct.HsMap (+  deriveHsHashMapUnsafe,+) where++import qualified Control.Monad+import Data.Char (isAlphaNum)+import qualified Data.HashMap.Strict as HashMap+import Language.Haskell.TH++import Foreign (Ptr)+import Foreign.C.Types (CSize)+import Foreign.CPP.Marshallable++-- HsHashMap -------------------------------------------------------------------++deriveHsHashMapUnsafe ::+  String -> TypeQ -> TypeQ -> Q [Dec]+deriveHsHashMapUnsafe cppType hsKeyType hsValType = do+  hashMapTypeStr <-+    map (\i -> if isAlphaNum i then i else '_') . pprint+      <$> hashMapType++  let cppConstructName = "map_construct" ++ cppName+      hsConstructName = mkName $ "c_map_construct" ++ hashMapTypeStr+  constructImport <-+    forImpD+      cCall+      unsafe+      cppConstructName+      hsConstructName+      [t|Ptr () -> CSize -> IO ()|]++  let cppAddName = "map_add" ++ cppName+      hsAddName = mkName $ "c_map_add" ++ hashMapTypeStr+  addImport <-+    forImpD+      cCall+      unsafe+      cppAddName+      hsAddName+      [t|Ptr () -> Ptr $hsKeyType -> Ptr $hsValType -> IO ()|]++  hsKT <- hsKeyType+  hsVT <- hsValType+  isKeyDestructible <- isInstance (mkName "Destructible") [hsKT]+  isValDestructible <- isInstance (mkName "Destructible") [hsVT]++  let keyWithFn = mkName $ if isKeyDestructible then "withCxxObject" else "with"+      valWithFn = mkName $ if isValDestructible then "withCxxObject" else "with"+      pN = mkName "p"+      hmN = mkName "hm"+      addChunk =+        [|+          Control.Monad.forM_ (HashMap.toList hm) $ \(key, val) ->+            $(varE keyWithFn) key $ \key_ptr ->+              $(varE valWithFn) val $ \val_ptr ->+                $(varE hsAddName) (castPtr p) key_ptr val_ptr+          |]++      -- newValue (HsHashMap _h) = error "HsHashMap cannot be made on the heap"+      newValueFn =+        funD+          (mkName "newValue")+          [ clause+              [conP (mkName "HsHashMap") [varP $ mkName "_h"]]+              (normalB [|error "HsHashMap cannot be made on the heap"|])+              []+          ]++      -- constructValue p (HsHashMap hm) = do+      --    $(varE hsConstructName) (castPtr p) (fromIntegral (length hm))+      --    Control.Monad.forM_ (toList hm) $ (\key, \val) ->+      --      $(varE withKeyFn) key $ \key_ptr ->+      --         $(varE withValFn) val $ \val_ptr ->+      --            $(varE hsAddName) (castPtr p) key_ptr val_ptr+      constructValueFn =+        funD+          (mkName "constructValue")+          [ clause+              [varP pN, conP (mkName "HsHashMap") [varP hmN]]+              ( normalB $+                  doE+                    [ noBindS+                        [|+                          $(varE hsConstructName)+                            (castPtr p)+                            (fromIntegral (length hm))+                          |]+                    , noBindS addChunk+                    ]+              )+              []+          ]++  -- instance Constructible (HsHashMap <TYPE>) where+  constructibleHashMapInst <-+    instanceD+      (cxt [])+      [t|Constructible $hashMapType|]+      [ newValueFn+      , constructValueFn+      ]++  return+    [ constructibleHashMapInst+    , constructImport+    , addImport+    ]+  where+    hashMapType = conT (mkName "HsHashMap") `appT` hsKeyType `appT` hsValType+    cppName = "HsMap" ++ cppType
+ Foreign/CPP/HsStruct/HsOption.hs view
@@ -0,0 +1,160 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE TemplateHaskell #-}+module Foreign.CPP.HsStruct.HsOption+  ( HsOption(..)+  , deriveHsOptionUnsafe+  ) where++import Data.Char (isAlphaNum)+import Foreign+import Language.Haskell.TH++import Foreign.CPP.Addressable+import Foreign.CPP.Marshallable++-- HsOption --------------------------------------------------------------------++newtype HsOption a = HsOption+  { hsOption :: Maybe a+  }++-- | This is a Template Haskell function which is used in conjunction with+-- @HS_OPTION_H@ and @HS_OPTION_CPP@ from "HsOption.h" to generate instances for+-- `HsOption T` for your type `T`+deriveHsOptionUnsafe+  :: String -> Int -> Int -> TypeQ -> Q [Dec]+deriveHsOptionUnsafe cppType sizeVal alignmentVal hsType = do+  optionTypeStr <-+    map (\i -> if isAlphaNum i then i else '_') . pprint <$> optionType++  -- instance Addressable (HsOption <TYPE>)+  addressableInst <- instanceD+    (cxt [])+    [t| Addressable $optionType |]+    []++  let+    -- sizeOf _ = #{size DummyHsOption<NAME>}+    sizeOfFn = funD (mkName "sizeOf")+      [ clause [wildP] (normalB $ litE $ integerL $ fromIntegral sizeVal) [] ]++    -- alignment _ = #{alignment DummyHsOption<NAME>}+    alignmentFn = funD (mkName "alignment")+      [ clause [wildP] (normalB $+          litE $ integerL $ fromIntegral alignmentVal) []+      ]++    -- poke = error "HsOption <TYPE> not pokeable"+    pokeFn = funD (mkName "poke")+      [ clause [] (normalB $+            varE (mkName "error") `appE`+            stringE (optionTypeStr ++ " not pokeable")+          )+          []+      ]++    pN = mkName "p"+    ptrN = mkName "ptr"+    peekN = mkName "peek"+    -- peek p = do+    --   ptr <- peekByteOff p 0  -- assume beginning of struct+    --   HsOption <$> maybePeek peek ptr+    peekFn = funD peekN+      [clause [varP pN] (normalB $ doE+        [ bindS+          (varP ptrN )+          (varE (mkName "peekByteOff") `appE` varE pN `appE` litE (integerL 0))+        , noBindS (infixApp+          (conE $ mkName "HsOption")+          (varE $ mkName "fmap")+          (varE (mkName "maybePeek") `appE` varE peekN `appE` varE ptrN)+          )+        ]) []]++  --  instance Storable (HsOption <TYPE>) where+  storableInst <- instanceD+    (cxt [])+    [t| Storable $optionType |]+    [sizeOfFn, alignmentFn, pokeFn, peekFn]++  let+    cppCtorName = "option_ctorHsOption" ++ cppType+    -- cppCtor = "void " ++ cppCtorName ++ "(void*, " ++ cppType ++ "*)"+    hsCtorName = mkName $ "c_ctor" ++ optionTypeStr++  -- foreign import ccall unsafe "<cppCtorName>"+  --   c_ctor<TYPE> :: Ptr (HsOption <TYPE>) -> Ptr <TYPE> -> IO ()+  ctorImport <- forImpD cCall unsafe cppCtorName hsCtorName+      [t| Ptr $optionType -> Ptr $hsType -> IO () |]++  let+    cppNewName = "option_newHsOption" ++ cppType+    -- cppNew = "void* " ++ cppNewName ++ "(" ++ cppType ++ "*)"+    hsNewName = mkName $ "c_new" ++ optionTypeStr++-- foreign import ccall unsafe "<cppNewName>"+--   c_new<TYPE> :: Ptr <TYPE> -> IO (Ptr (HsOption <TYPE>))+  newImport <- forImpD cCall unsafe cppNewName hsNewName+      [t| Ptr $hsType -> IO (Ptr $optionType) |]++  hsT <- hsType+  isDestructible <- isInstance (mkName "Destructible") [hsT]++  let+    optN = mkName "HsOption"+    nothingN = mkName "Nothing"+    justN = mkName "Just"+    vN = mkName "v"++    withFn = if isDestructible then "withCxxObject" else "with"++    -- newValue (HsOption Nothing) = newDefault+    -- newValue (HsOption (Just v)) =+    --   withCxxObject v $ c_newOption+    newValueFn = funD (mkName "newValue")+      [ clause [conP optN [conP nothingN []]] (normalB $+          varE (mkName "newDefault")) [],+        clause [conP optN [conP justN [varP vN]]] (normalB $+          infixApp+          (varE (mkName withFn) `appE` varE vN)+          (varE (mkName "$"))+          (varE hsNewName)+          ) []+      ]++    -- constructValue p (HsOption Nothing) = constructDefault p+    -- constructValue p (HsOption (Just v)) =+    --   withCxxObject v $ c_ctorOption p+    constructValueFn = funD (mkName "constructValue")+      [ clause [varP pN, conP optN [conP nothingN []]] (normalB $+          varE (mkName "constructDefault") `appE` varE pN) [],+        clause [varP pN, conP optN [conP justN [varP vN]]] (normalB $+          infixApp+          (varE (mkName withFn) `appE` varE vN)+          (varE (mkName "$"))+          (varE hsCtorName `appE` varE pN)+          ) []+      ]++  --  instance Constructible (HsOption <TYPE>) where+  constructibleInst <- instanceD+    (cxt [])+    [t| Constructible $optionType |]+    [newValueFn, constructValueFn]++  return+    [ addressableInst+    , storableInst+    , ctorImport+    , newImport+    , constructibleInst+    ]+  where+    optionType = [t| HsOption $hsType |]
+ Foreign/CPP/HsStruct/HsSet.hs view
@@ -0,0 +1,116 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE TemplateHaskell #-}++module Foreign.CPP.HsStruct.HsSet (+  deriveHsHashSetUnsafe,+) where++import qualified Control.Monad+import Data.Char (isAlphaNum)+import Language.Haskell.TH++import Foreign (Ptr)+import Foreign.C.Types (CSize)+import Foreign.CPP.Marshallable++-- HsHashSet -------------------------------------------------------------------++deriveHsHashSetUnsafe ::+  String -> TypeQ -> Q [Dec]+deriveHsHashSetUnsafe cppType hsType = do+  hashSetTypeStr <-+    map (\i -> if isAlphaNum i then i else '_') . pprint+      <$> hashSetType++  let cppConstructName = "set_construct" ++ cppName+      hsConstructName = mkName $ "c_set_construct" ++ hashSetTypeStr+  constructImport <-+    forImpD+      cCall+      unsafe+      cppConstructName+      hsConstructName+      [t|Ptr () -> CSize -> IO ()|]++  let cppAddName = "set_add" ++ cppName+      hsAddName = mkName $ "c_set_add" ++ hashSetTypeStr+  addImport <-+    forImpD+      cCall+      unsafe+      cppAddName+      hsAddName+      [t|Ptr () -> Ptr $hsType -> IO ()|]++  hsT <- hsType+  isDestructible <- isInstance (mkName "Destructible") [hsT]++  let withFn = mkName $ if isDestructible then "withCxxObject" else "with"+      pN = mkName "p"+      keysN = mkName "keys"++      addChunk =+        [|+          Control.Monad.forM_ keys $ \key ->+            $(varE withFn) key $ \key_ptr ->+              $(varE hsAddName) (castPtr p) key_ptr+          |]++      -- newValue (HsHashSet _h) = error "HsHashSet cannot be made on the heap"+      newValueFn =+        funD+          (mkName "newValue")+          [ clause+              [conP (mkName "HsHashSet") [varP $ mkName "_h"]]+              (normalB [|error "HsHashSet cannot be made on the heap"|])+              []+          ]++      -- constructValue (HsHashSet h) = do+      --    $(varE hsConstructName) (castPtr p) (fromIntegral (length keys)+      --    Control.Monad.forM_ keys $ \key ->+      --      $(varE withFn) key $ \key_ptr ->+      --        $(varE hsAddName) (castPtr p) key_ptr+      constructValueFn =+        funD+          (mkName "constructValue")+          [ clause+              [varP pN, conP (mkName "HsHashSet") [varP keysN]]+              ( normalB $+                  doE+                    [ noBindS+                        [|+                          $(varE hsConstructName)+                            (castPtr p)+                            (fromIntegral (length keys))+                          |]+                    , noBindS addChunk+                    ]+              )+              []+          ]++  -- instance Constructible (HsHashSet <TYPE>) where+  constructibleHashSetInst <-+    instanceD+      (cxt [])+      [t|Constructible $hashSetType|]+      [ newValueFn+      , constructValueFn+      ]++  return+    [ constructibleHashSetInst+    , constructImport+    , addImport+    ]+  where+    hashSetType = conT (mkName "HsHashSet") `appT` hsType+    cppName = "HsSet" ++ cppType
+ Foreign/CPP/HsStruct/HsStdTuple.hs view
@@ -0,0 +1,155 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE TemplateHaskell #-}+module Foreign.CPP.HsStruct.HsStdTuple+  ( deriveHsStdTupleUnsafe+  , HsStdTuple(..)+  ) where++import Data.List (foldl')+import Control.Monad (forM, unless)+import Foreign+import Language.Haskell.TH++import Foreign.CPP.Addressable+import Foreign.CPP.Marshallable+++newtype HsStdTuple a = HsStdTuple { unHsStdTuple :: a }++deriveHsStdTupleUnsafe+  :: String -> Int -> Int -> TypeQ -> Q [Dec]+deriveHsStdTupleUnsafe cppType sizeVal alignmentVal hsType = do+  hsStdTupleType <- [t| HsStdTuple |]+  hsTRaw <- hsType+  let+    (hsT, tupleType) = case hsTRaw of+      (AppT a b) | a == hsStdTupleType -> (b, hsType)+      _ -> (hsTRaw, [t| HsStdTuple $hsType |])+    (numTypes, hsTypes) = unfoldTupleT hsT++  unless (numTypes > 0) $+    fail "StdTuple must be a tuple with 1 or more underlying types"++  hsTypesDestructible <-+    forM hsTypes $ \t -> isInstance (mkName "Destructible") [t]++  addressableInst <- instanceD+    (cxt [])+    [t| Addressable $tupleType |]+    []++  let+    sizeOfFn = funD (mkName "sizeOf")+      [ clause [wildP] (normalB $ litE $ integerL $ fromIntegral sizeVal) [] ]++    alignmentFn = funD (mkName "alignment")+      [ clause [wildP] (normalB $+          litE $ integerL $ fromIntegral alignmentVal) []+      ]++    ptrN = mkName "ptr"+    pNames = take numTypes $ idxNames "p"+    vNames = take numTypes $ idxNames "v"+    pvZipped = zip pNames vNames+    pCasted = map (\p -> parensE $ varE castPtrN `appE` varE p) pNames++    hsPokeName = mkName $ "c_poke_" ++ cppName+    cppPokeName = "std_tuple_poke_" ++ cppName++    nestedPokeFns = nestPokeFns (zip3 vNames pNames hsTypesDestructible) $ doE+      -- c_poke* FFI call+      [ noBindS (foldl' appE+          (varE hsPokeName `appE` [| castPtr ptr|] `appE` [|nullPtr|])+          pCasted+        )+      ]++    pokeFn = funD (mkName "poke")+      [ clause [varP ptrN, conP (mkName "HsStdTuple") [tupP (map varP vNames)]]+          (normalB nestedPokeFns) []+      ]++    hsPeekName = mkName $ "c_peek_" ++ cppName+    cppPeekName = "std_tuple_peek_" ++ cppName++    nestedPeekFns = nestPeekFns (zip pNames hsTypesDestructible) $+      doE $+        -- c_peek* FFI call+        [noBindS (foldl' appE+            (varE hsPeekName `appE` [| castPtr ptr|] `appE` [|nullPtr|])+            pCasted+          )+        ] +++        -- N peeks+        map (\(p, v) -> bindS (varP v) (varE (mkName "peek") `appE` varE p))+          pvZipped +++        -- tuple construction+        [noBindS (varE (mkName "return") `appE`+          parensE (conE (mkName "HsStdTuple") `appE` tupE (map varE vNames)))+        ]++    peekFn = funD (mkName "peek")+      [ clause [varP ptrN] (normalB nestedPeekFns) []+      ]++  storableInst <- instanceD+    (cxt [])+    [t| Storable $tupleType |]+    [sizeOfFn, alignmentFn, pokeFn, peekFn]++  peekImport <- forImpD cCall unsafe cppPeekName hsPeekName $+    -- Ptr () -> Ptr () -> <<< all tuple types >>> -> IO ()+    foldl' (\b a -> [t| $a -> $b |]) [t| IO () |] $+      map (\a -> [t| Ptr $a |]) ([t|()|] : [t| ()|] : map return hsTypes)++  pokeImport <- forImpD cCall unsafe cppPokeName hsPokeName $+    -- Ptr () -> Ptr () -> <<< all tuple types >>> -> IO ()+    foldl' (\b a -> [t| $a -> $b |]) [t| IO () |] $+      map (\a -> [t| Ptr $a |]) ([t|()|] : [t| ()|] : map return hsTypes)++  constructibleInst <- instanceD+    (cxt [])+    [t| Constructible $tupleType |]+    []++  return+    [ addressableInst+    , storableInst+    , constructibleInst+    , peekImport+    , pokeImport+    ]+  where+    unfoldTupleT :: Type -> (Int, [Type])+    unfoldTupleT (AppT a b) = let+      (i, ts) = unfoldTupleT a+      in (i, ts ++ [b])+    unfoldTupleT (TupleT i) = (i, [])+    unfoldTupleT n = (1, [n])++    castPtrN = mkName "castPtr"+    cppName = cppType++    idxNames c = map (\i -> mkName (c ++ show i)) [0::Int ..]++    nestPeekFns :: [(Name, Bool)] -> ExpQ -> ExpQ+    nestPeekFns [] base = base+    nestPeekFns ((p, isDestructible):ts) base =+      varE (mkName allocFn) `appE` lamE [varP p] (nestPeekFns ts base)+      where+        allocFn = if isDestructible then "withDefaultCxxObject" else "alloca"++    nestPokeFns :: [(Name, Name, Bool)] -> ExpQ -> ExpQ+    nestPokeFns [] base = base+    nestPokeFns ((v, p, isDestructible):ts) base =+      varE (mkName withObjFn) `appE` varE v `appE`+        lamE [varP p] (nestPokeFns ts base)+      where+        withObjFn = if isDestructible then "withCxxObject" else "with"
+ Foreign/CPP/HsStruct/HsStdVariant.hs view
@@ -0,0 +1,153 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE TemplateHaskell #-}++module Foreign.CPP.HsStruct.HsStdVariant+  ( deriveHsStdVariantUnsafe+  ) where++import Language.Haskell.TH++import Foreign+import Foreign.C.Types+import Foreign.CPP.Addressable+import Foreign.CPP.Marshallable++deriveHsStdVariantUnsafe+  :: String -> Int -> Int -> String -> TypeQ -> Q [Dec]+deriveHsStdVariantUnsafe cppName sizeVal alignmentVal hsName hsType = do+  typeName <- do+    v <- lookupTypeName hsName+    case v of+      Just val -> return val+      Nothing -> fail ("Unable to find type " ++ hsName)+  -- Get the constructors from the data type+  constructors <- do+    info <- reify typeName+    case info of+      -- start zip from `1` since `0` corresponds to `monostate`+      TyConI (DataD _ _ _ _ cons' _) -> return $ zip [1..] cons'+      _ -> fail ("Unsupported type for HsStdVariant " ++ hsName)++  addressableInst <- instanceD+    (cxt [])+    [t| Addressable $hsType |]+    []++  let (cppPeekValName, hsPeekValName) = importNames "peek"+  peekValImport <- forImpD cCall unsafe cppPeekValName hsPeekValName+    [t| Ptr () -> Ptr CInt -> IO (Ptr ()) |]++  let (cppPokeValName, hsPokeValName) = importNames "poke"+  pokeValImport <- forImpD cCall unsafe cppPokeValName hsPokeValName+    [t| Ptr () -> Ptr () -> CInt -> IO () |]++  (peekMatches, pokeClauses) <-+    unzip <$> mapM (getConData hsPokeValName) constructors++  -- Storable+  let+    sizeOfFn = funD (mkName "sizeOf")+      [ clause [wildP] (normalB $ litE $ integerL $ fromIntegral sizeVal) [] ]++    alignmentFn = funD (mkName "alignment")+      [ clause [wildP] (normalB $+          litE $ integerL $ fromIntegral alignmentVal) []+      ]++    pokeFn = funD (mkName "poke") pokeClauses++    idxN = mkName "idx"+    idxpN = mkName "idx_p"+    peekN = mkName "peek"++    -- Peek by calling `hsPeekValName` to extract idx and ptr+    -- Unknown returned index results in `error`+    peekFn = funD peekN+      [clause [varP pN]+        (normalB $ varE (mkName "alloca") `appE` lamE [varP idxpN] (doE+          [ bindS+            (varP valpN)+            (varE hsPeekValName `appE`+              parensE (varE castPtrN `appE` varE pN) `appE`+              varE idxpN)+          , bindS (varP idxN) (varE peekN `appE` varE idxpN)+          , noBindS (caseE (varE idxN) (peekMatches +++              [ match wildP (normalB $+                varE (mkName "error") `appE` parensE+                  (infixApp+                    (stringE ("Unable to peek " ++ hsName ++ " with index "))+                    (varE $ mkName "++")+                    (varE (mkName "show") `appE` varE idxN)+                  )+                ) []+              ])+            )+          ])) []+      ]++  storableInst <- instanceD+    (cxt [])+    [t| Storable $hsType |]+    [sizeOfFn, alignmentFn, pokeFn, peekFn]+++  -- Constructible+  constructibleInst <- instanceD+    (cxt [])+    [t| Constructible $hsType |]+    []++  return+    [ addressableInst+    , constructibleInst+    , peekValImport+    , pokeValImport+    , storableInst+    ]+  where+    pN = mkName "p"+    castPtrN = mkName "castPtr"+    valpN = mkName "__val_p"++    importNames pre = ("std_variant_" ++ base, mkName $ "c_" ++ base)+      where+        base = pre ++ cppName++    getConData hsPokeName (idx, NormalC name [(_, t)] ) = do+        isDestructible <- isInstance (mkName "Destructible") [t]++        let+          -- A match clause for the given index, using the constructor `name`+          -- after `peek`ing the result+          peekMatch = match (litP $ integerL idx) (normalB $ infixApp+              (conE name)+              (varE $ mkName "fmap")+              (varE (mkName "peek") `appE` parensE (varE castPtrN `appE`+                varE valpN))+            )+            []++        let+          valN = mkName "__val"+          withObjFn = if isDestructible then "withCxxObject" else "with"+          -- Matching against the particular constructor `name`,+          -- Using with/withCxxObject to get a pointer to the underlying data+          -- to send down+          pokeClause = clause [varP pN, conP name [varP valN]] (normalB $+            varE (mkName withObjFn) `appE` varE valN `appE` lamE [varP valpN] (+              varE hsPokeName `appE`+              parensE (varE castPtrN `appE` varE pN) `appE`+              parensE (varE castPtrN `appE` varE valpN) `appE`+              litE (integerL idx)+            ))+            []++        return (peekMatch, pokeClause)+    getConData _ _ = fail "Only take unnamed constructors with 1 type"
+ Foreign/CPP/HsStruct/Types.hsc view
@@ -0,0 +1,999 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Foreign.CPP.HsStruct.Types+  ( StorableContainer(..)+  -- * HsRange+  , HsRange(..)+  , HsStringPiece+  , withByteStringAsHsStringPiece+  , withTextAsHsStringPiece+  -- * HsMaybe+  , HsMaybe(..)+  -- * HsOption+  , HsOption(..)+  -- * HsEither+  , HsEither(..)+  , peekHsEitherWith+  -- * HsPair+  , HsPair(..)+  , peekHsPairWith+  -- * HsStdTuple+  , HsStdTuple(..)+  -- * HsString+  , HsString(..)+  , HsByteString(..)+  , HsText(..)+  , HsLenientText(..)+  -- * HsArray+  , HsArray(..)+  , HsArrayStorable(..)+  , HsList(..)+  -- * HsMap+  , HsMap(..)+  , HsIntMap(..)+  , HsHashMap(..)+  , HsObject(..)+  , HsHashSet(..)+  -- * HsJSON+  , HsJSON(..)+  ) where++import Control.DeepSeq (NFData)+import Data.Aeson (Value(..))+import Data.ByteString (ByteString, packCStringLen)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import Data.Hashable (Hashable, hashWithSalt)+import Data.Text (Text)+import qualified Data.Text.Encoding as Text (encodeUtf8)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashSet as HashSet+import Data.IntMap.Strict (IntMap)+import Data.Map.Strict (Map)+import Data.Scientific+  (fromFloatDigits, floatingOrInteger, toBoundedInteger, toRealFloat)+import Data.Vector (Vector, generateM)+import qualified Data.Vector.Storable as VS+import qualified Data.Vector as Vector+import Foreign hiding (void)+import Foreign.C+import qualified Data.HashMap.Strict as HashMap+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Map.Strict as Map++import Foreign.CPP.Addressable hiding (alignment, sizeOf)+import qualified Foreign.CPP.Addressable as Addressable+import Foreign.CPP.HsStruct.HsArray+import Foreign.CPP.HsStruct.HsSet+import Foreign.CPP.HsStruct.HsMap+import Foreign.CPP.HsStruct.HsOption+import Foreign.CPP.HsStruct.HsStdTuple+import Foreign.CPP.HsStruct.Utils+import Foreign.CPP.Marshallable.TH+import Mangle.TH+import Util.Aeson+import Util.FFI+import Util.Text (cStringLenToText, cStringLenToTextLenient)++#include <hsc.h>+#include <cpp/HsOption.h>+#include <cpp/HsStdTuple.h>+#include <cpp/HsStdVariant.h>+#include <cpp/HsStruct.h>++-- | An abstraction over storable containers. The elements will be marshaled or+-- interpreted by given function. The element type must be 'Addressable'+-- (with 'sizeOf' and 'alignment' defined) in order to use 'peekWith' and+-- 'pokeWith'.+--+-- Compared with creating a newtype for the element type, it will avoid+--  * duplicate identical implementation of 'sizeOf' and 'pokeWith'+--  * a trivial newtype unwrapping+--  * an unsafe 'castPtr' in some cases+-- while introduce some risk of using wrong marshalers.+class StorableContainer f where+  -- | Given a function to read each element, reads the whole container from+  -- the specified memory location+  peekWith :: Addressable a => (Ptr a -> IO b) -> Ptr (f a) -> IO (f b)+  -- | Given a function to write each element, writes the whole container to+  -- the specified memory location+  pokeWith+    :: Addressable a => (Ptr a -> b -> IO ()) -> Ptr (f a) -> f b -> IO ()++-- The default way to read and write a container. Require 'peek'/'poke' for+-- element type being implemented to use 'peek'/'poke' for the whole container.+instance {-# OVERLAPPABLE #-}+    (Addressable1 f, StorableContainer f, Addressable a, Storable a) =>+    Storable (f a) where+  sizeOf = sizeOf1+  alignment = alignment1+  peek = peekWith peek+  poke = pokeWith poke++peekElemOffWith :: forall a b. Addressable a+                => (Ptr a -> IO b) -> Ptr a -> Int -> IO b+peekElemOffWith f p i = f $ p `plusPtr` (i * offset)+  where+  offset = Addressable.sizeOf (undefined :: a)++notPokeable :: String -> a+notPokeable t = error $ "HsStruct." <> t <> " is not HS_POKEABLE"++-- HsRange --------------------------------------------------------------------++data HsRange a n = HsRange (Ptr a) n++instance Integral n => Storable (HsRange a n) where+  sizeOf _ = #{size DummyHsRange}+  alignment _ = #{alignment DummyHsRange}+  peek p = do+    (a :: Ptr a) <- #{peek DummyHsRange, a} p+    (n :: CSize) <- #{peek DummyHsRange, n} p+    return $ HsRange a $ fromIntegral n+  poke p (HsRange a n) = do+    #{poke DummyHsRange, a} p a+    #{poke DummyHsRange, n} p (fromIntegral n :: CSize)++type HsStringPiece = HsRange CChar Int++$(mangle+  "void ctorHsStringPiece(HsRange<char>*, const char*, size_t)"+  [d|+    foreign import ccall unsafe+      c_constructHsStringPiece :: Ptr HsStringPiece -> CString -> Word -> IO ()+  |])++$(mangle+  "HsStringPiece* newHsStringPiece(const char*, size_t)"+  [d|+    foreign import ccall unsafe+      c_newHsStringPiece :: CString -> Word -> IO (Ptr HsStringPiece)+  |])++instance Constructible HsStringPiece where+  newValue (HsRange str len) =+    castPtr <$> c_newHsStringPiece str (fromIntegral len)+  constructValue p (HsRange str len) =+    c_constructHsStringPiece (castPtr p) str (fromIntegral len)++instance Addressable HsStringPiece++withByteStringAsHsStringPiece+  :: ByteString -> (HsStringPiece -> IO res) -> IO res+withByteStringAsHsStringPiece b act = unsafeUseAsCStringLen b $ \cstrlen ->+  act (uncurry HsRange cstrlen)++withTextAsHsStringPiece :: Text -> (HsStringPiece -> IO res) -> IO res+withTextAsHsStringPiece b = withByteStringAsHsStringPiece (Text.encodeUtf8 b)++-- HsMaybe --------------------------------------------------------------------++newtype HsMaybe a = HsMaybe+  { hsMaybe :: Maybe a+  }++instance Addressable1 HsMaybe where+  sizeOf1 _ = #{size DummyHsMaybe}+  alignment1 _ = #{alignment DummyHsMaybe}++instance Addressable (HsMaybe a) where+  sizeOf = sizeOf1+  alignment = alignment1++instance StorableContainer HsMaybe where+  pokeWith = notPokeable "HsMaybe"+  peekWith f p = do+    ptr <- #{peek DummyHsMaybe, ptr} p+    HsMaybe <$> maybePeek f ptr++-- HsString -------------------------------------------------------------------++newtype HsString = HsString+  { hsString :: String+  }++$(mangle+  "void ctorHsString(HsString*, const char*, size_t)}"+  [d|+    foreign import ccall unsafe+      c_constructHsString :: Ptr HsString -> CString -> Word -> IO ()+  |])++$(mangle+  "HsString* newHsString(const char*, size_t)}"+  [d|+    foreign import ccall unsafe+      c_newHsString :: CString -> Word -> IO (Ptr HsString)+  |])++instance Addressable HsString++instance Storable HsString where+  sizeOf _ = #{size HsString}+  alignment _ = #{alignment HsString}+  poke = notPokeable "HsString"+  peek p = fmap HsString $ peekCStringLen =<< peekStrLen p++peekStrLen :: Ptr a -> IO CStringLen+peekStrLen p = do+  (str :: CString) <- #{peek HsString, str} p+  (len :: CSize) <- #{peek HsString, len} p+  return (str, fromIntegral len)++newStrImpl :: ByteString -> IO (Ptr a)+newStrImpl bs = castPtr <$> (unsafeUseAsCStringLen bs $ \(str, len) ->+  c_newHsString str (fromIntegral len))++constructStrImpl :: Ptr a -> ByteString -> IO ()+constructStrImpl p bs = unsafeUseAsCStringLen bs $ \(str, len) ->+  c_constructHsString (castPtr p) str (fromIntegral len)++-- HsText ---------------------------------------------------------------++newtype HsText = HsText+  { hsText :: Text+  }++instance Addressable HsText where+  sizeOf _ = #{size HsString}+  alignment _ = #{alignment HsString}++instance Constructible HsText where+  newValue (HsText txt) = newStrImpl (Text.encodeUtf8 txt)+  constructValue p (HsText txt) =+    constructStrImpl (castPtr p) (Text.encodeUtf8 txt)++instance Storable HsText where+  sizeOf _ = #{size HsString}+  alignment _ = #{alignment HsString}+  poke = error "HsStruct.HsText: poke not implemented"+  peek p = fmap HsText $ uncurry cStringLenToText =<< peekStrLen p++instance Eq HsText where+  (HsText a) == (HsText b) = a == b++instance Hashable HsText where+  hashWithSalt i (HsText a) = hashWithSalt i a++-- HsEither -------------------------------------------------------------------++#{enum HsEitherTag, HsEitherTag+  , hs_Left = HS_LEFT+  , hs_Right = HS_RIGHT+  }++newtype HsEitherTag = HsEitherTag #{type HsEitherTag}+  deriving (Eq, Storable)++newtype HsEither a b = HsEither+  { hsEither :: Either a b+  } deriving NFData++$(mangle+  "void* newHsEither(HsEitherTag, void*)}"+  [d|+    foreign import ccall unsafe+      c_newHsEither :: HsEitherTag -> Ptr c -> IO (Ptr (HsEither a b))+  |])++instance Addressable1 (HsEither a) where+  sizeOf1 _ = #{size DummyHsEither}+  alignment1 _ = #{alignment DummyHsEither}++instance Addressable (HsEither a b) where+  sizeOf = sizeOf1+  alignment = alignment1++instance Storable a => StorableContainer (HsEither a) where+  pokeWith = notPokeable "HsEither"+  peekWith = peekHsEitherWith peek++peekHsEitherWith+  :: (Ptr a -> IO x)+  -> (Ptr b -> IO y)+  -> Ptr (HsEither a b)+  -> IO (HsEither x y)+peekHsEitherWith peekLeft peekRight p = do+  isLeft <- #{peek DummyHsEither, isLeft} p :: IO CChar+  if toBool isLeft+  then do+    ptr <- #{peek DummyHsEither, left} p+    HsEither . Left <$> peekLeft ptr+  else do+    ptr <- #{peek DummyHsEither, right} p+    HsEither . Right <$> peekRight ptr++instance (Constructible a, Constructible b)+  => Constructible (HsEither a b) where+  newValue (HsEither (Left a)) = do+    p_left <- newValue a+    c_newHsEither hs_Left p_left+  newValue (HsEither (Right b)) = do+    p_right <- newValue b+    c_newHsEither hs_Right p_right++  constructValue p (HsEither (Left a)) = do+    p_left <- newValue a+    #{poke DummyHsEither, isLeft} p (fromIntegral (1::Int) :: CBool)+    #{poke DummyHsEither, left} p p_left+  constructValue p (HsEither (Right b)) = do+    #{poke DummyHsEither, isLeft} p (fromIntegral (0::Int) :: CBool)+    p_right <- newValue b+    #{poke DummyHsEither, right} p p_right++-- HsPair ---------------------------------------------------------------------++newtype HsPair a b = HsPair+  { hsPair :: (a, b)+  }++instance Addressable1 (HsPair a) where+  sizeOf1 _ = #{size DummyHsPair}+  alignment1 _ = #{alignment DummyHsPair}++instance Addressable (HsPair a b) where+  sizeOf = sizeOf1+  alignment = alignment1++instance Storable a => StorableContainer (HsPair a) where+  pokeWith = notPokeable "HsPair"+  peekWith = peekHsPairWith peek++peekHsPairWith+  :: (Ptr a -> IO x)+  -> (Ptr b -> IO y)+  -> Ptr (HsPair a b)+  -> IO (HsPair x y)+peekHsPairWith peekFirst peekSecond p = do+  ptr_a <- #{peek DummyHsPair, fst_} p+  fs <- peekFirst ptr_a+  ptr_b <- #{peek DummyHsPair, snd_} p+  sn <- peekSecond ptr_b+  return $ HsPair (fs, sn)++-- HsByteString ---------------------------------------------------------------++newtype HsByteString = HsByteString+  { hsByteString :: ByteString+  } deriving NFData++instance Addressable HsByteString where+  sizeOf _ = #{size HsString}+  alignment _ = #{alignment HsString}++instance Constructible HsByteString where+  newValue (HsByteString bs) = newStrImpl bs+  constructValue p (HsByteString bs) = constructStrImpl (castPtr p) bs++instance Storable HsByteString where+  sizeOf _ = #{size HsString}+  alignment _ = #{alignment HsString}+  poke = notPokeable "HsByteString"+  peek p = fmap HsByteString $ packCStringLen =<< peekStrLen p++instance Eq HsByteString where+  (HsByteString a) == (HsByteString b) = a == b++instance Hashable HsByteString where+  hashWithSalt i (HsByteString a) = hashWithSalt i a++-- HsLenientText --------------------------------------------------------------++newtype HsLenientText = HsLenientText+  { hsLenientText :: Text+  } deriving (Eq, Hashable)++instance Addressable HsLenientText++instance Constructible HsLenientText where+  newValue (HsLenientText txt) = newStrImpl (Text.encodeUtf8 txt)+  constructValue p (HsLenientText txt) =+    constructStrImpl (castPtr p) (Text.encodeUtf8 txt)++instance Storable HsLenientText where+  sizeOf _ = #{size HsString}+  alignment _ = #{alignment HsString}+  poke = notPokeable "HsLenientText"+  peek p = fmap HsLenientText $ uncurry cStringLenToTextLenient =<< peekStrLen p++-- HsArray+newtype HsArray a = HsArray+  { hsArray :: Vector a+  }++instance Addressable1 HsArray where+  sizeOf1 _ = #{size DummyHsArray}+  alignment1 _ = #{alignment DummyHsArray}++instance Addressable (HsArray a) where+  sizeOf = sizeOf1+  alignment = alignment1++instance StorableContainer HsArray where+  pokeWith = notPokeable "HsArray"+  peekWith f p = do+    (a, n) <- peekDataSize p+    fmap HsArray . generateM n $ \i -> peekElemOffWith f a i++-- | 'HsArrayStorable' is 'HsArray' with a more efficient+-- representation, which can be passed back out to C++ without copying+-- using Vector.Storable.unsafeWith.+newtype HsArrayStorable a = HsArrayStorable+  { hsArrayStorable :: VS.Vector a+  }++instance Storable a => Storable (HsArrayStorable a) where+  sizeOf _ = #{size DummyHsArray}+  alignment _ = #{alignment DummyHsArray}+  poke = notPokeable "HsArrayStorable"+  peek p = do+    (a, n) <- peekDataSize p+    arr <- mallocForeignPtrArray n+    unsafeWithForeignPtr arr $ \parr -> copyBytes parr a (n * sizeOf (undefined :: a))+    return (HsArrayStorable (VS.unsafeFromForeignPtr0 arr n))++-- HsList+newtype HsList a = HsList+  { hsList :: [a]+  }++instance Addressable1 HsList where+  sizeOf1 _ = #{size DummyHsArray}+  alignment1 _ = #{alignment DummyHsArray}++instance Addressable (HsList a) where+  sizeOf = sizeOf1+  alignment = alignment1++instance StorableContainer HsList where+  pokeWith = notPokeable "HsList"+  peekWith f p = do+    (a, n) <- peekDataSize p+    let go !i !acc+          | i < 0 = return acc+          | otherwise = do+              e <- peekElemOffWith f a i+              go (i-1) (e:acc)+    HsList <$> go (n-1) []++peekDataSize :: Ptr b -> IO (Ptr a, Int)+peekDataSize p = do+  (a :: Ptr a) <- #{peek DummyHsArray, a} p+  (n :: CSize) <- #{peek DummyHsArray, n} p+  return (a, fromIntegral n)++-- HsSet+newtype HsHashSet a = HsHashSet+  -- Contains a List as a transport for the internal datatype that may not be+  -- immediately hashable in haskell (i.e. CLong is not hashable, but the end+  -- type of Int is)+  { hsHashSet :: HashSet.HashSet a+  }++instance Addressable1 HsHashSet where+  sizeOf1 = setSizeOf+  alignment1 = setAlignment++instance Addressable (HsHashSet a) where+  sizeOf = sizeOf1+  alignment = alignment1++instance (Addressable a, Eq a, Hashable a, Storable a)+  => Storable (HsHashSet a) where+  sizeOf = sizeOf1+  alignment = alignment1+  poke = notPokeable "HsHashSet"+  peek p = HsHashSet <$> peekSetWith HashSet.empty HashSet.insert peek p++{-# INLINE peekSetWith #-}+peekSetWith+  :: (Addressable a)+  => s+  -> (k -> s -> s)+  -> (Ptr a -> IO k)+  -> Ptr b+  -> IO s+peekSetWith empty insert f p = do+  (a :: Ptr a) <- #{peek DummyHsSet, keys} p+  (n :: Int) <- (fromIntegral :: CSize -> Int) <$> #{peek DummyHsSet, n} p+  let go !i !hs+        | i >= n = return hs+        | otherwise = do+            k <- peekElemOffWith f a i+            go (i + 1) $ insert k hs+  go 0 empty++setSizeOf, setAlignment :: a -> Int+setSizeOf _ = #{size DummyHsSet}+setAlignment _ = #{alignment DummyHsSet}++-- HsMap+newtype HsMap k v = HsMap+  { hsMap :: Map k v+  }++instance Addressable1 (HsMap k) where+  sizeOf1 = mapSizeOf+  alignment1 = mapAlignment++instance Addressable (HsMap k v) where+  sizeOf = sizeOf1+  alignment = alignment1++instance (Addressable k, Ord k, Storable k) => StorableContainer (HsMap k) where+  pokeWith = notPokeable "HsMap"+  peekWith f p = HsMap <$> peekMapWith Map.empty Map.insert peek f p++newtype HsIntMap v = HsIntMap+  { hsIntMap :: IntMap v+  }++instance Addressable1 HsIntMap where+  sizeOf1 = mapSizeOf+  alignment1 = mapAlignment++instance Addressable (HsIntMap v) where+  sizeOf = sizeOf1+  alignment = alignment1++instance StorableContainer HsIntMap where+  pokeWith = notPokeable "HsIntMap"+  peekWith f p = HsIntMap <$> peekMapWith IntMap.empty IntMap.insert peek f p++newtype HsHashMap k v = HsHashMap+  { hsHashMap :: HashMap k v+  }++instance Addressable1 (HsHashMap k) where+  sizeOf1 = mapSizeOf+  alignment1 = mapAlignment++instance Addressable (HsHashMap k v) where+  sizeOf = sizeOf1+  alignment = alignment1++instance (Addressable k, Eq k, Hashable k, Storable k)+  => StorableContainer (HsHashMap k) where+  pokeWith = notPokeable "HsHashMap"+  peekWith f p = HsHashMap <$> peekMapWith HashMap.empty HashMap.insert peek f p++newtype HsObject v = HsObject+  { hsObject :: KeyMap v+  }++instance Addressable1 HsObject where+  sizeOf1 = mapSizeOf+  alignment1 = mapAlignment++instance Addressable (HsObject v) where+  sizeOf = sizeOf1+  alignment = alignment1++instance StorableContainer HsObject where+  pokeWith = notPokeable "HsObject"+  peekWith f p = HsObject <$> peekMapWith emptyKeyMap insertKeyMap fk f p+    where+    fk = fmap (keyFromText . hsText) . peek++mapSizeOf, mapAlignment :: a -> Int+mapSizeOf _ = #{size DummyHsObject}+mapAlignment _ = #{alignment DummyHsObject}++foreign import ccall unsafe "common_hs_ctorHsObjectJSON"+  c_constructHsObjectJSON+    :: Ptr (HsObject HsJSON)+    -> Ptr (HsArray HsText)+    -> Ptr (HsArray HsJSON)+    -> IO ()++{-# INLINE peekMapWith #-}+peekMapWith+  :: (Addressable a, Addressable b)+  => m+  -> (k -> v -> m -> m)+  -> (Ptr a -> IO k)+  -> (Ptr b -> IO v)+  -> Ptr c+  -> IO m+peekMapWith empty insert fk fv p = do+  size <- (fromIntegral :: CSize -> Int) <$> #{peek DummyHsObject, n} p+  keys <- #{peek DummyHsObject, keys} p+  values <- #{peek DummyHsObject, values} p+  let go !i !hm+        | i >= size = return hm+        | otherwise = do+            k <- peekElemOffWith fk keys i+            v <- peekElemOffWith fv values i+            go (i+1) $ insert k v hm+  go 0 empty++-- HsJSON+newtype HsJSON = HsJSON+  { hsJSON :: Value+  }++instance Addressable HsJSON++instance Storable HsJSON where+  sizeOf _ = #{size HsJSON}+  alignment _ = #{alignment HsJSON}+  poke = notPokeable "HsJSON"+  peek p = do+    (t :: CInt) <- #{peek HsJSON, type} p+    #{let json_type t = "%d", static_cast<int>(HsJSON::Type::t)}+    HsJSON <$> case t of+      #{json_type Null} ->+        return Null+      #{json_type Bool} ->+        Bool . toBool <$> peekIntegral+      #{json_type Integral} ->+        Number . fromIntegral <$> peekIntegral+      #{json_type Real} ->+        Number . fromFloatDigits <$> (#{peek HsJSON, real} p :: IO CDouble)+      #{json_type String} ->+        String . hsText <$> #{peek HsJSON, string} p+      #{json_type Array} ->+        Array . fmap hsJSON . hsArray <$> #{peek HsJSON, array} p+      #{json_type Object} ->+        Object . fmap hsJSON . hsObject <$> #{peek HsJSON, object} p+      _ ->+        error "HsStruct.HsJSON: invalid HsJSON::Type"+    where+    peekIntegral = #{peek HsJSON, integral} p :: IO CLong++$(mangle+  "void ctorHsJSONNull(HsJSON*)"+  [d|+    foreign import ccall unsafe+      c_constructHsJSONNull :: Ptr HsJSON -> IO ()+  |])++$(mangle+  "void ctorHsJSONBool(HsJSON*, bool)"+  [d|+    foreign import ccall unsafe+      c_constructHsJSONBool :: Ptr HsJSON -> CBool -> IO ()+  |])++$(mangle+  "void ctorHsJSONInt(HsJSON*, int64_t)"+  [d|+    foreign import ccall unsafe+      c_constructHsJSONInt :: Ptr HsJSON -> CLong -> IO ()+  |])++$(mangle+  "void ctorHsJSONDouble(HsJSON*, double)"+  [d|+    foreign import ccall unsafe+      c_constructHsJSONDouble :: Ptr HsJSON -> CDouble -> IO ()+  |])++$(mangle+  "void ctorHsJSONString(HsJSON*, HsString*)"+  [d|+    foreign import ccall unsafe+      c_constructHsJSONString :: Ptr HsJSON -> Ptr HsText -> IO ()+  |])++$(mangle+  "void ctorHsJSONArray(HsJSON*, HsArray<HsJSON>*)"+  [d|+    foreign import ccall unsafe+      c_constructHsJSONArray :: Ptr HsJSON -> Ptr (HsArray HsJSON) -> IO ()+  |])++$(mangle+  "void ctorHsJSONObject(HsJSON*, HsMap<HsString, HsJSON>*)"+  [d|+    foreign import ccall unsafe+      c_constructHsJSONObject :: Ptr HsJSON -> Ptr (HsObject HsJSON) -> IO ()+  |])++-- Derive Marshallables first+$(deriveMarshallableUnsafe "HsMaybeInt" [t| HsMaybe Int |])+$(deriveMarshallableUnsafe "HsMaybeDouble" [t| HsMaybe Double |])+$(deriveMarshallableUnsafe "HsMaybeString" [t| HsMaybe HsByteString |])+$(deriveMarshallableUnsafe "HsMaybeString" [t| HsMaybe HsText |])+$(deriveMarshallableUnsafe "HsMaybeString" [t| HsMaybe HsLenientText |])++$(deriveMarshallableUnsafe "HsEitherStringInt" [t| HsEither HsText Int |])+$(deriveMarshallableUnsafe "HsEitherStringDouble" [t| HsEither HsText Double |])+$(deriveMarshallableUnsafe "HsEitherStringString" [t| HsEither HsText HsByteString |])+$(deriveMarshallableUnsafe "HsEitherStringString" [t| HsEither HsText HsText |])+$(deriveMarshallableUnsafe "HsEitherStringInt" [t| HsEither HsLenientText Int |])+$(deriveMarshallableUnsafe "HsEitherStringDouble" [t| HsEither HsLenientText Double |])+$(deriveMarshallableUnsafe "HsEitherStringString" [t| HsEither HsLenientText HsByteString |])+$(deriveMarshallableUnsafe "HsEitherStringString" [t| HsEither HsLenientText HsLenientText |])++$(deriveMarshallableUnsafe "HsEitherStringArrayInt" [t| HsEither HsText (HsList Int) |])+$(deriveMarshallableUnsafe "HsEitherStringArrayDouble" [t| HsEither HsText (HsList Double) |])+$(deriveMarshallableUnsafe "HsEitherStringArrayString" [t| HsEither HsText (HsList HsByteString) |])+$(deriveMarshallableUnsafe "HsEitherStringArrayString" [t| HsEither HsText (HsList HsText) |])+$(deriveMarshallableUnsafe "HsEitherStringArrayInt" [t| HsEither HsLenientText (HsList Int) |])+$(deriveMarshallableUnsafe "HsEitherStringArrayDouble" [t| HsEither HsLenientText (HsList Double) |])+$(deriveMarshallableUnsafe "HsEitherStringArrayString" [t| HsEither HsLenientText (HsList HsByteString) |])+$(deriveMarshallableUnsafe "HsEitherStringArrayString" [t| HsEither HsLenientText (HsList HsLenientText) |])++instance Assignable (HsEither HsText Int)+instance Assignable (HsEither HsText Double)+instance Assignable (HsEither HsText HsByteString)+instance Assignable (HsEither HsText HsText)++$(deriveMarshallableUnsafe "HsString" [t| HsString |])+$(deriveMarshallableUnsafe "HsString" [t| HsByteString |])+$(deriveMarshallableUnsafe "HsString" [t| HsLenientText |])+$(deriveMarshallableUnsafe "HsString" [t| HsText |])++instance Assignable HsText+instance Assignable HsByteString+instance Assignable HsLenientText++$(deriveMarshallableUnsafe "HsStringPiece" [t| HsStringPiece |])++$(deriveMarshallableUnsafe "HsOptionBool" [t| HsOption Bool |])+$(deriveMarshallableUnsafe "HsOptionBool" [t| HsOption CBool |])+$(deriveMarshallableUnsafe "HsOptionInt16" [t| HsOption CShort |])+$(deriveMarshallableUnsafe "HsOptionInt16" [t| HsOption Int16 |])+$(deriveMarshallableUnsafe "HsOptionInt32" [t| HsOption CInt |])+$(deriveMarshallableUnsafe "HsOptionInt32" [t| HsOption Int32 |])+$(deriveMarshallableUnsafe "HsOptionInt64" [t| HsOption CLong |])+$(deriveMarshallableUnsafe "HsOptionInt64" [t| HsOption Int64 |])+$(deriveMarshallableUnsafe "HsOptionUInt8" [t| HsOption CSChar |])+$(deriveMarshallableUnsafe "HsOptionUInt8" [t| HsOption Word8 |])+$(deriveMarshallableUnsafe "HsOptionUInt32" [t| HsOption CUInt |])+$(deriveMarshallableUnsafe "HsOptionUInt32" [t| HsOption Word32 |])+$(deriveMarshallableUnsafe "HsOptionUInt64" [t| HsOption CULong |])+$(deriveMarshallableUnsafe "HsOptionUInt64" [t| HsOption Word64 |])+$(deriveMarshallableUnsafe "HsOptionFloat" [t| HsOption Float |])+$(deriveMarshallableUnsafe "HsOptionFloat" [t| HsOption CFloat |])+$(deriveMarshallableUnsafe "HsOptionDouble" [t| HsOption Double |])+$(deriveMarshallableUnsafe "HsOptionDouble" [t| HsOption CDouble |])+$(deriveMarshallableUnsafe "HsOptionString" [t| HsOption HsText |])+$(deriveMarshallableUnsafe "HsOptionString" [t| HsOption HsLenientText |])+$(deriveMarshallableUnsafe "HsOptionString" [t| HsOption HsByteString |])+$(deriveMarshallableUnsafe "HsOptionStringView" [t| HsOption HsStringPiece |])+$(deriveMarshallableUnsafe "HsOptionHsJSON" [t| HsOption HsJSON |])++$(deriveMarshallableUnsafe "HsArrayInt16" [t| HsList CShort |])+$(deriveMarshallableUnsafe "HsArrayInt16" [t| HsList Int16 |])+$(deriveMarshallableUnsafe "HsArrayInt32" [t| HsList CInt |])+$(deriveMarshallableUnsafe "HsArrayInt32" [t| HsList Int32 |])+$(deriveMarshallableUnsafe "HsArrayInt64" [t| HsList Int |])+$(deriveMarshallableUnsafe "HsArrayInt64" [t| HsList Int64 |])+$(deriveMarshallableUnsafe "HsArrayInt64" [t| HsList CLong |])+$(deriveMarshallableUnsafe "HsArrayUInt8" [t| HsList CBool |])+$(deriveMarshallableUnsafe "HsArrayUInt8" [t| HsList Word8 |])+$(deriveMarshallableUnsafe "HsArrayUInt32" [t| HsList CUInt |])+$(deriveMarshallableUnsafe "HsArrayUInt32" [t| HsList Word32 |])+$(deriveMarshallableUnsafe "HsArrayUInt64" [t| HsList CULong |])+$(deriveMarshallableUnsafe "HsArrayUInt64" [t| HsList Word64 |])+$(deriveMarshallableUnsafe "HsArrayFloat" [t| HsList Float |])+$(deriveMarshallableUnsafe "HsArrayFloat" [t| HsList CFloat |])+$(deriveMarshallableUnsafe "HsArrayDouble" [t| HsList Double |])+$(deriveMarshallableUnsafe "HsArrayDouble" [t| HsList CDouble |])+$(deriveMarshallableUnsafe "HsArrayString" [t| HsList HsByteString |])+$(deriveMarshallableUnsafe "HsArrayString" [t| HsList HsText |])+$(deriveMarshallableUnsafe "HsArrayString" [t| HsList HsLenientText |])+$(deriveMarshallableUnsafe "HsArrayStringPiece" [t| HsList HsStringPiece |])+$(deriveMarshallableUnsafe "HsArrayJSON" [t| HsList HsJSON |])+$(deriveMarshallableUnsafe "HsArrayInt16" [t| HsArray CShort |])+$(deriveMarshallableUnsafe "HsArrayInt16" [t| HsArray Int16 |])+$(deriveMarshallableUnsafe "HsArrayInt32" [t| HsArray CInt |])+$(deriveMarshallableUnsafe "HsArrayInt32" [t| HsArray Int32 |])+$(deriveMarshallableUnsafe "HsArrayInt64" [t| HsArray Int |])+$(deriveMarshallableUnsafe "HsArrayInt64" [t| HsArray Int64 |])+$(deriveMarshallableUnsafe "HsArrayInt64" [t| HsArray CLong |])+$(deriveMarshallableUnsafe "HsArrayUInt8" [t| HsArray CBool |])+$(deriveMarshallableUnsafe "HsArrayUInt8" [t| HsArray Word8 |])+$(deriveMarshallableUnsafe "HsArrayUInt8" [t| HsArray CSChar |])+$(deriveMarshallableUnsafe "HsArrayUInt8" [t| HsArray CUChar |])+$(deriveMarshallableUnsafe "HsArrayUInt16" [t| HsArray CUShort |])+$(deriveMarshallableUnsafe "HsArrayUInt32" [t| HsArray CUInt |])+$(deriveMarshallableUnsafe "HsArrayUInt32" [t| HsArray Word32 |])+$(deriveMarshallableUnsafe "HsArrayUInt64" [t| HsArray CULong |])+$(deriveMarshallableUnsafe "HsArrayUInt64" [t| HsArray Word64 |])+$(deriveMarshallableUnsafe "HsArrayFloat" [t| HsArray Float |])+$(deriveMarshallableUnsafe "HsArrayFloat" [t| HsArray CFloat |])+$(deriveMarshallableUnsafe "HsArrayDouble" [t| HsArray Double |])+$(deriveMarshallableUnsafe "HsArrayDouble" [t| HsArray CDouble |])+$(deriveMarshallableUnsafe "HsArrayString" [t| HsArray HsByteString |])+$(deriveMarshallableUnsafe "HsArrayString" [t| HsArray HsText |])+$(deriveMarshallableUnsafe "HsArrayString" [t| HsArray HsLenientText |])+$(deriveMarshallableUnsafe "HsArrayStringPiece" [t| HsArray HsStringPiece |])+$(deriveMarshallableUnsafe "HsArrayJSON" [t| HsArray HsJSON |])++$(deriveMarshallableUnsafe "HsSetUInt8" [t| HsHashSet CUChar |])+$(deriveMarshallableUnsafe "HsSetUInt16" [t| HsHashSet CUShort |])+$(deriveMarshallableUnsafe "HsSetInt32" [t| HsHashSet CInt |])+$(deriveMarshallableUnsafe "HsSetInt32" [t| HsHashSet Int32 |])+$(deriveMarshallableUnsafe "HsSetInt64" [t| HsHashSet Int |])+$(deriveMarshallableUnsafe "HsSetInt64" [t| HsHashSet Int64 |])+$(deriveMarshallableUnsafe "HsSetInt64" [t| HsHashSet CLong |])+$(deriveMarshallableUnsafe "HsSetUInt8" [t| HsHashSet CBool |])+$(deriveMarshallableUnsafe "HsSetUInt8" [t| HsHashSet Word8 |])+$(deriveMarshallableUnsafe "HsSetUInt8" [t| HsHashSet CSChar |])+$(deriveMarshallableUnsafe "HsSetUInt32" [t| HsHashSet CUInt |])+$(deriveMarshallableUnsafe "HsSetUInt32" [t| HsHashSet Word32 |])+$(deriveMarshallableUnsafe "HsSetUInt64" [t| HsHashSet CULong |])+$(deriveMarshallableUnsafe "HsSetUInt64" [t| HsHashSet Word64 |])+$(deriveMarshallableUnsafe "HsSetFloat" [t| HsHashSet Float |])+$(deriveMarshallableUnsafe "HsSetDouble" [t| HsHashSet Double |])+$(deriveMarshallableUnsafe "HsSetString" [t| HsHashSet HsByteString |])+$(deriveMarshallableUnsafe "HsSetString" [t| HsHashSet HsText |])+$(deriveMarshallableUnsafe "HsSetString" [t| HsHashSet HsLenientText |])+$(deriveMarshallableUnsafe "HsSetJSON" [t| HsHashSet HsJSON |])++$(deriveMarshallableUnsafe "HsMapIntInt" [t| HsIntMap Int |])+$(deriveMarshallableUnsafe "HsMapUInt8UInt8" [t| HsHashMap CUChar CUChar |])+$(deriveMarshallableUnsafe "HsMapUInt16UInt16" [t| HsHashMap CUShort CUShort |])+$(deriveMarshallableUnsafe "HsMapIntDouble" [t| HsIntMap Double |])+$(deriveMarshallableUnsafe "HsMapIntString" [t| HsIntMap HsByteString |])+$(deriveMarshallableUnsafe "HsMapIntString" [t| HsIntMap HsText |])+$(deriveMarshallableUnsafe "HsMapIntString" [t| HsIntMap HsLenientText |])+$(deriveMarshallableUnsafe "HsMapStringInt" [t| HsObject Int |])+$(deriveMarshallableUnsafe "HsMapStringDouble" [t| HsObject Double |])+$(deriveMarshallableUnsafe "HsMapStringString" [t| HsObject HsByteString |])+$(deriveMarshallableUnsafe "HsMapStringString" [t| HsObject HsText |])+$(deriveMarshallableUnsafe "HsMapStringString" [t| HsObject HsLenientText |])++$(deriveMarshallableUnsafe "HsMapIntInt" [t| HsHashMap Int Int |])+$(deriveMarshallableUnsafe "HsMapInt32Int32" [t| HsHashMap Int32 Int32 |])+$(deriveMarshallableUnsafe "HsMapInt32Double" [t| HsHashMap Int32 Double |])+$(deriveMarshallableUnsafe "HsMapInt32String" [t| HsHashMap Int32 HsText |])+$(deriveMarshallableUnsafe "HsMapInt32String" [t| HsHashMap Int32 HsLenientText |])+$(deriveMarshallableUnsafe "HsMapInt32String" [t| HsHashMap Int32 HsByteString |])+$(deriveMarshallableUnsafe "HsMapDoubleInt32" [t| HsHashMap Double Int32 |])+$(deriveMarshallableUnsafe "HsMapStringInt32" [t| HsHashMap HsByteString Int32 |])+$(deriveMarshallableUnsafe "HsMapStringInt32" [t| HsHashMap HsText Int32 |])+$(deriveMarshallableUnsafe "HsMapStringInt32" [t| HsHashMap HsLenientText Int32 |])+$(deriveMarshallableUnsafe "HsMapStringDouble" [t| HsHashMap HsByteString Double |])+$(deriveMarshallableUnsafe "HsMapStringDouble" [t| HsHashMap HsText Double |])+$(deriveMarshallableUnsafe "HsMapStringDouble" [t| HsHashMap HsLenientText Double |])+$(deriveMarshallableUnsafe "HsMapStringString" [t| HsHashMap HsText HsText |])+$(deriveMarshallableUnsafe "HsMapStringString" [t| HsHashMap HsText HsByteString |])+$(deriveMarshallableUnsafe "HsMapStringString" [t| HsHashMap HsLenientText HsLenientText |])+$(deriveMarshallableUnsafe "HsMapStringString" [t| HsHashMap HsLenientText HsByteString |])+$(deriveMarshallableUnsafe "HsMapStringString" [t| HsHashMap HsByteString HsText |])+$(deriveMarshallableUnsafe "HsMapStringString" [t| HsHashMap HsByteString HsLenientText |])+$(deriveMarshallableUnsafe "HsMapStringString" [t| HsHashMap HsByteString HsByteString |])++$(deriveMarshallableUnsafe "HsObjectJSON" [t| HsObject HsJSON |])+$(deriveMarshallableUnsafe "HsJSON" [t| HsJSON |])++-- These are mutually recurisve, we have to splice them together+$(do+  a <- deriveHsArrayUnsafe "HsJSON" [t| HsJSON |]+  b <- deriveHsArrayUnsafe "String" [t| HsText |]+  c <- [d|+    instance Constructible HsJSON where+      newValue (HsJSON _val) = error $ "HsStruct.HsJSON cannot be built on heap"+      constructValue ptr (HsJSON val) =+        case val of+          Null -> c_constructHsJSONNull ptr+          Bool b -> c_constructHsJSONBool ptr (fromBool b)+          Number n -> case (floatingOrInteger n :: Either CDouble CLong) of+            Left r -> c_constructHsJSONDouble ptr r+            Right _ -> case toBoundedInteger n of+              Just i -> c_constructHsJSONInt ptr i+              Nothing -> c_constructHsJSONDouble ptr $ toRealFloat n+          String txt -> withCxxObject (HsText txt) $ c_constructHsJSONString ptr+          Array v -> withCxxObject (HsArray (Vector.map HsJSON v)) $+            c_constructHsJSONArray ptr+          Object o -> withCxxObject (HsObject (HsJSON <$> o)) $+            c_constructHsJSONObject ptr++    instance Constructible (HsObject HsJSON) where+      newValue (HsObject _o) = error "HsObject HsJSON cannot be made on heap"+      constructValue ptr (HsObject m) =+        withCxxObject (HsArray (Vector.fromList (map (HsText . keyToText) keys))) $ \keys_p ->+        withCxxObject (HsArray (Vector.fromList vals)) $ \vals_p ->+          c_constructHsObjectJSON ptr keys_p vals_p+        where+          (keys, vals) = unzip $ objectToList m+   |]+  return $ a ++ b ++ c+ )++-- Derive constructions after marshallable+$(#{derive_hs_option_unsafe Bool} [t| Bool |])+$(#{derive_hs_option_unsafe Bool} [t| CBool |])+$(#{derive_hs_option_unsafe Int16} [t| CShort |])+$(#{derive_hs_option_unsafe Int16} [t| Int16 |])+$(#{derive_hs_option_unsafe Int32} [t| CInt |])+$(#{derive_hs_option_unsafe Int32} [t| Int32 |])+$(#{derive_hs_option_unsafe Int64} [t| CLong |])+$(#{derive_hs_option_unsafe Int64} [t| Int64 |])+$(#{derive_hs_option_unsafe UInt8} [t| CSChar |])+$(#{derive_hs_option_unsafe UInt8} [t| Word8 |])+$(#{derive_hs_option_unsafe UInt32} [t| CUInt |])+$(#{derive_hs_option_unsafe UInt32} [t| Word32 |])+$(#{derive_hs_option_unsafe UInt64} [t| CULong |])+$(#{derive_hs_option_unsafe UInt64} [t| Word64 |])+$(#{derive_hs_option_unsafe Float} [t| Float |])+$(#{derive_hs_option_unsafe Float} [t| CFloat |])+$(#{derive_hs_option_unsafe Double} [t| Double |])+$(#{derive_hs_option_unsafe Double} [t| CDouble |])+$(#{derive_hs_option_unsafe String} [t| HsText |])+$(#{derive_hs_option_unsafe String} [t| HsLenientText |])+$(#{derive_hs_option_unsafe String} [t| HsByteString |])+$(#{derive_hs_option_unsafe StringView} [t| HsStringPiece |])+$(#{derive_hs_option_unsafe HsJSON} [t| HsJSON |])++$(deriveHsArrayUnsafe "Int16" [t| CShort |])+$(deriveHsArrayUnsafe "Int16" [t| Int16 |])+$(deriveHsArrayUnsafe "Int32" [t| CInt |])+$(deriveHsArrayUnsafe "Int32" [t| Int32 |])+$(deriveHsArrayUnsafe "Int64" [t| CLong |])+$(deriveHsArrayUnsafe "Int64" [t| Int64 |])+$(deriveHsArrayUnsafe "UInt8" [t| CBool |])+$(deriveHsArrayUnsafe "UInt8" [t| Word8 |])+$(deriveHsArrayUnsafe "UInt8" [t| CUChar |])+$(deriveHsArrayUnsafe "UInt8" [t| CSChar |])+$(deriveHsArrayUnsafe "UInt16" [t| CUShort |])+$(deriveHsArrayUnsafe "UInt32" [t| CUInt |])+$(deriveHsArrayUnsafe "UInt32" [t| Word32 |])+$(deriveHsArrayUnsafe "UInt64" [t| CULong |])+$(deriveHsArrayUnsafe "UInt64" [t| Word64 |])+$(deriveHsArrayUnsafe "Float" [t| Float |])+$(deriveHsArrayUnsafe "Float" [t| CFloat |])+$(deriveHsArrayUnsafe "Double" [t| Double |])+$(deriveHsArrayUnsafe "Double" [t| CDouble |])+$(deriveHsArrayUnsafe "String" [t| HsLenientText |])+$(deriveHsArrayUnsafe "String" [t| HsByteString |])+$(deriveHsArrayUnsafe "StringView" [t| HsStringPiece |])++$(deriveHsHashSetUnsafe "Int16" [t| CShort |])+$(deriveHsHashSetUnsafe "Int16" [t| Int16 |])+$(deriveHsHashSetUnsafe "Int32" [t| CInt |])+$(deriveHsHashSetUnsafe "Int32" [t| Int32 |])+$(deriveHsHashSetUnsafe "Int64" [t| Int |])+$(deriveHsHashSetUnsafe "Int64" [t| Int64 |])+$(deriveHsHashSetUnsafe "Int64" [t| CLong |])+$(deriveHsHashSetUnsafe "UInt8" [t| CBool |])+$(deriveHsHashSetUnsafe "UInt8" [t| Word8 |])+$(deriveHsHashSetUnsafe "UInt8" [t| CSChar |])+$(deriveHsHashSetUnsafe "UInt8" [t| CUChar |])+$(deriveHsHashSetUnsafe "UInt16" [t| CUShort |])+$(deriveHsHashSetUnsafe "UInt32" [t| CUInt |])+$(deriveHsHashSetUnsafe "UInt32" [t| Word32 |])+$(deriveHsHashSetUnsafe "UInt64" [t| CULong |])+$(deriveHsHashSetUnsafe "UInt64" [t| Word64 |])+$(deriveHsHashSetUnsafe "Float" [t| Float |])+$(deriveHsHashSetUnsafe "Double" [t| Double |])+$(deriveHsHashSetUnsafe "String" [t| HsByteString |])+$(deriveHsHashSetUnsafe "String" [t| HsText |])+$(deriveHsHashSetUnsafe "String" [t| HsLenientText |])+$(deriveHsHashSetUnsafe "HsJSON" [t| HsJSON |])++-- O(n^2) derivations, try to derive just what you need+$(deriveHsHashMapUnsafe "IntInt" [t| Int |] [t| Int |])+$(deriveHsHashMapUnsafe "UInt8UInt8" [t| CUChar |] [t| CUChar |])+$(deriveHsHashMapUnsafe "UInt16UInt16" [t| CUShort |] [t| CUShort |])+$(deriveHsHashMapUnsafe "Int32Int32" [t| Int32 |] [t| Int32 |])+$(deriveHsHashMapUnsafe "Int32Double" [t| Int32 |] [t| Double |])+$(deriveHsHashMapUnsafe "Int32String" [t| Int32 |] [t| HsByteString |])+$(deriveHsHashMapUnsafe "Int32String" [t| Int32 |] [t| HsText |])+$(deriveHsHashMapUnsafe "Int32String" [t| Int32 |] [t| HsLenientText |])+$(deriveHsHashMapUnsafe "DoubleInt32" [t| Double |] [t| Int32 |])+$(deriveHsHashMapUnsafe "StringInt32" [t| HsByteString |] [t| Int32 |])+$(deriveHsHashMapUnsafe "StringInt32" [t| HsText |] [t| Int32 |])+$(deriveHsHashMapUnsafe "StringInt32" [t| HsLenientText |] [t| Int32 |])+$(deriveHsHashMapUnsafe "StringDouble" [t| HsText |] [t| Double |])+$(deriveHsHashMapUnsafe "StringDouble" [t| HsLenientText |] [t| Double |])+$(deriveHsHashMapUnsafe "StringDouble" [t| HsByteString |] [t| Double |])+$(deriveHsHashMapUnsafe "StringString" [t| HsText |] [t| HsText |])+$(deriveHsHashMapUnsafe "StringString" [t| HsText |] [t| HsByteString |])+$(deriveHsHashMapUnsafe "StringString" [t| HsLenientText |] [t| HsLenientText |])+$(deriveHsHashMapUnsafe "StringString" [t| HsLenientText |] [t| HsByteString |])+$(deriveHsHashMapUnsafe "StringString" [t| HsByteString |] [t| HsText |])+$(deriveHsHashMapUnsafe "StringString" [t| HsByteString |] [t| HsLenientText |])+$(deriveHsHashMapUnsafe "StringString" [t| HsByteString |] [t| HsByteString |])
+ Foreign/CPP/HsStruct/Unsafe.hsc view
@@ -0,0 +1,56 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Foreign.CPP.HsStruct.Unsafe+  ( unsafeMaybeRelease+  , unsafeMaybeSteal+  , unsafeMaybePeek+  , unsafeToHsStringPiece+  ) where++import Control.Exception+import Data.ByteString (ByteString)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import Foreign++import Foreign.CPP.Marshallable+import Foreign.CPP.HsStruct.Types++#include <cpp/HsStruct.h>++-- | Returns the raw pointer to the optional foreign object in the 'HsMaybe'.+-- The 'HsMaybe' releases the ownership and becomes owning nothing.+-- Think is as calling @std::unique_ptr::release()@.+--+-- Haskell takes the responsibility of handling exceptions including+-- asynchronous exceptions and ensure the foreign object is disposed of+-- properly. Do /not/ use this function unless you intend to take over the+-- ownership /and/ extend the lifetime of the foreign object. Otherwise,+-- simply leave the ownership to C++ and keep the 'HsMaybe' intact.+--+-- Use 'unsafeMaybeSteal' whenever the foreign object can be disposed of by+-- calling 'delete' from 'Destructible'.+unsafeMaybeRelease :: Ptr (HsMaybe a) -> IO (Ptr a)+unsafeMaybeRelease p = do+  ptr <- #{peek DummyHsMaybe, ptr} p+  #{poke DummyHsMaybe, ptr} p nullPtr+  return ptr++unsafeMaybePeek :: Ptr (HsMaybe a) -> IO (Ptr a)+unsafeMaybePeek p = #{peek DummyHsMaybe, ptr} p++-- | Steals the raw pointer to the optional foreign object in 'HsMaybe'.+-- Haskell takes over the ownership and takes the responsibility of disposing+-- of it by calling 'delete'. The 'HsMaybe' releases the ownership and becomes+-- owning nothing. Think it as calling+-- @std::shared_ptr::shared_ptr(std::unique_ptr&&)@.+unsafeMaybeSteal :: Destructible a => Ptr (HsMaybe a) -> IO (ForeignPtr a)+unsafeMaybeSteal p = mask_ $ toSharedPtr =<< unsafeMaybeRelease p++unsafeToHsStringPiece :: ByteString -> IO HsStringPiece+unsafeToHsStringPiece s = unsafeUseAsCStringLen s $ return . uncurry HsRange
+ Foreign/CPP/HsStruct/Utils.hs view
@@ -0,0 +1,43 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Foreign.CPP.HsStruct.Utils+  ( withCxxObject+  , withDefaultCxxObject+  ) where+++import Control.Exception (bracket)+import Foreign (Ptr)+import Foreign.CPP.Addressable+import Foreign.CPP.Marshallable++import Util.Memory++-- | allocates space for an object, calls `constructValue` with a value+-- and `destruct`s the object when done.+withCxxObject+  :: (Constructible a, Destructible a, Addressable a)+  => a+  -> (Ptr a -> IO b)+  -> IO b+withCxxObject val func =+  allocaBytesAligned (sizeOf val) (alignment val) $ \s ->+    bracket (constructValue s val >> return s) destruct func++-- | allocates space for an object, calls `constructDefault`+-- and `destruct`s the object when done.+withDefaultCxxObject+  :: forall a b . (DefaultConstructible a, Destructible a, Addressable a)+  => (Ptr a -> IO b)+  -> IO b+withDefaultCxxObject func =+  allocaBytesAligned (sizeOf val) (alignment val) $ \s ->+    bracket (constructDefault s >> return s) destruct func+  where+    val = undefined :: a
+ Foreign/CPP/Marshallable.hs view
@@ -0,0 +1,181 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE DefaultSignatures #-}+module Foreign.CPP.Marshallable+  ( makeShared+  , toSharedPtr+  , destructAndFree+  , DefaultConstructible(..)+  , Constructible(..)+  , Destructible(..)+  , Assignable(..)+  ) where++-- Importing types for default instantiations of Constructible+import Data.Ratio (Ratio)+import Foreign.C.Types+import GHC.Fingerprint (Fingerprint)+import System.Posix.Types++import Foreign.Storable+import Foreign.Marshal.Utils+import Control.Exception (mask_)+import Foreign hiding (alloca, allocaBytes, allocaArray)+++-- Utility functions ----------------------------------------------------------++-- | Returns a 'ForeignPtr' that owns and manages a foreign object through+-- a pointer and disposes of that object when the lifetime of the 'ForeignPtr'+-- ends.+-- It is similar to @std::make_shared<T>@ in C++.+-- The object pointed to is both allocated+ctor'd and+-- destructed+deallocated in C+++makeShared :: (DefaultConstructible a, Destructible a) => IO (ForeignPtr a)+makeShared = newDefault >>= toSharedPtr++-- | Returns a 'ForeignPtr' that owns and manages a foreign object through+-- a pointer and disposes of that object when the lifetime of the 'ForeignPtr'+-- ends.+toSharedPtr :: Destructible a => Ptr a -> IO (ForeignPtr a)+toSharedPtr = newForeignPtr deleteFunPtr++-- | Simply calls 'destruct' and 'free'. This should be used instead of+-- 'delete' when the memory is allocated by 'malloc' or 'mallocBytes' in+-- Haskell and the object is constructed by __placement new__ in C++, or+-- 'construct' / 'constructDefault' in Haskell.+destructAndFree :: Destructible a => Ptr a -> IO ()+destructAndFree p = destruct p >> free p++-- Typeclasses ----------------------------------------------------------------++-- | Typeclass to call into C++ allocators and constructors for objects.+class DefaultConstructible a where+  -- | Allocate the space and invoke the constructor in C++.+  --+  -- This is equivalent to __new expression__ in C++, and assumes that+  -- the object has an empty constructor defined in its class definition.+  newDefault :: IO (Ptr a)++  -- | Invoke the construct of the object in C++. It does no checks on+  -- whether the ptr points to an already constructed object.+  --+  -- This is often used with 'Foreign.Marshal.Alloc.alloca' in Haskell,+  -- to do __placement new__ in C++.+  constructDefault :: Ptr a -> IO ()+++-- | Similar to @DefaultConstructible@ but also initializes the value for+-- the foreign object+-- Default implementations of storable types allow using common types like+-- Int, Char etc inside other complex types like HsEither.+-- You *must* not use these default implementations when defining instances for+-- complex C++ types. Doing so may lead to memory leaks.+class Constructible a where+  newValue :: a -> IO (Ptr a)+  default newValue :: Storable a => a -> IO (Ptr a)+  newValue = new++  constructValue :: Ptr a -> a -> IO ()+  default constructValue :: Storable a => Ptr a -> a -> IO ()+  constructValue = poke++instance Constructible Bool+instance Constructible Char+instance Constructible Double+instance Constructible Float+instance Constructible Int+instance Constructible Int8+instance Constructible Int16+instance Constructible Int32+instance Constructible Int64+instance Constructible Word+instance Constructible Word8+instance Constructible Word16+instance Constructible Word32+instance Constructible Word64+instance Constructible ()+instance Constructible Fingerprint+instance Constructible CUIntMax+instance Constructible CIntMax+instance Constructible CUIntPtr+instance Constructible CIntPtr+instance Constructible CSUSeconds+instance Constructible CUSeconds+instance Constructible CTime+instance Constructible CClock+instance Constructible CSigAtomic+instance Constructible CWchar+instance Constructible CSize+instance Constructible CPtrdiff+instance Constructible CDouble+instance Constructible CFloat+instance Constructible CULLong+instance Constructible CLLong+instance Constructible CULong+instance Constructible CLong+instance Constructible CUInt+instance Constructible CInt+instance Constructible CUShort+instance Constructible CShort+instance Constructible CUChar+instance Constructible CSChar+instance Constructible CChar+instance Constructible CBool+instance Constructible IntPtr+instance Constructible WordPtr+instance Constructible Fd+instance Constructible CRLim+instance Constructible CTcflag+instance Constructible CSpeed+instance Constructible CCc+instance Constructible CUid+instance Constructible CNlink+instance Constructible CGid+instance Constructible CSsize+instance Constructible CPid+instance Constructible COff+instance Constructible CMode+instance Constructible CIno+instance Constructible CDev+instance (Storable a, Integral a) => Constructible (Ratio a)+++-- | Typeclass to call into C++ destructors and deallocators for objects.+class Destructible a where+  -- | Invoke the destructor to free the resources owned by the object,+  -- the storage of the object itself is untouched, the object must not be+  -- used after this.+  --+  -- This is often used with 'Foreign.Marshal.Alloc.alloca' in Haskell+  -- and __placement new__ in C++.+  destruct :: Ptr a -> IO ()++  -- | Invoke the destructor and also deallocate the storage of the object.+  -- The object must not be used after this.+  --+  -- This is equivalent to __delete expression__ in C++, so the object+  -- must be a non-array object created by a __new expression__ in C++.+  delete :: Ptr a -> IO ()++  -- | Returns the pointer to the foreign delete function, i.e. the one+  -- called by @delete@ above.+  -- This is often used as the 'FinalizerPtr' of 'ForeignPtr'.+  deleteFunPtr :: FunPtr (Ptr a -> IO ())+++-- | Typeclass to read/write values to foreign objects. Implements the+-- functionality provided by @Storable@ typeclass, but for complex C++ objects.+-- The class instance must ensure that values being "poked" are correctly+-- destructed before assignment.+class Assignable a where+  -- | Write a value to given memory location. Similar to @Storable.poke@+  assign :: Ptr a -> a -> IO ()+  default assign :: (Constructible a, Destructible a) => Ptr a -> a -> IO ()+  assign p val = mask_ $ destruct p >> constructValue p val
+ Foreign/CPP/Marshallable/TH.hs view
@@ -0,0 +1,135 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{- |+This module provides facilities to auto generate instances for+@DefaultConstructible@ and @Destructible@ typeclasses. It depends+on certain functions being exposed via C++, which can also be generated+by using C++ macros defined in 'Marshallable.h'.+-}+{-# LANGUAGE TemplateHaskell #-}+module Foreign.CPP.Marshallable.TH+  ( module Marshallable+    -- Generate both DefaultConstructible and Destructible instances+  , deriveMarshallableUnsafe+  , deriveMarshallableSafe+    -- Generate Destructible instance+  , deriveDestructibleSafe+  , deriveDestructibleUnsafe+    -- Generate DefaultConstructible instance+  , deriveDefConstructibleUnsafe+  , deriveDefConstructibleSafe+  ) where++import Control.Monad (liftM2)+import Data.Char+import Foreign.Ptr+import Language.Haskell.TH++import Foreign.CPP.Marshallable as Marshallable++-- | This is a Template Haskell function which is used in conjunction with+-- @HS_DEFINE_DESTRUCTIBLE@ from "Destructible.h" to generate instances for+-- 'Destructible'. Use 'deriveDestructibleSafe' instead if the destructor+-- can block.+deriveDestructibleUnsafe :: String -> TypeQ -> Q [Dec]+deriveDestructibleUnsafe = derive destructSpec unsafe++-- | This is the safe version of 'deriveDestructibleUnsafe'. Use this instead+-- if the destructor can block.+deriveDestructibleSafe :: String -> TypeQ -> Q [Dec]+deriveDestructibleSafe = derive destructSpec safe++-- | This is a Template Haskell function which is used in conjunction with+-- @HS_DEFINE_DEFAULT_CONSTRUCTIBLE@ from "Construcible.h" to generate+-- instances for 'DefaultConstrucible'. Use 'deriveDefConstructibleSafe'+-- instead if the constructor can block.+deriveDefConstructibleUnsafe :: String -> TypeQ -> Q [Dec]+deriveDefConstructibleUnsafe = derive constructSpec unsafe++-- | This is the safe version of 'deriveDefConstructibleUnsafe'. Use this+-- instead if the constructor can block.+deriveDefConstructibleSafe :: String -> TypeQ -> Q [Dec]+deriveDefConstructibleSafe = derive constructSpec safe++-- | Function to generate both @DefaultConstructible@ and @Destructible@+-- instances.+deriveMarshallableUnsafe :: String -> TypeQ -> Q [Dec]+deriveMarshallableUnsafe cppName hsType = liftM2 (++)+  (deriveDefConstructibleUnsafe cppName hsType)+  (deriveDestructibleUnsafe cppName hsType)++-- | Safe version of @deriveMarshallableUnsafe@.+deriveMarshallableSafe :: String -> TypeQ -> Q [Dec]+deriveMarshallableSafe cppName hsType = liftM2 (++)+  (deriveDefConstructibleSafe cppName hsType)+  (deriveDestructibleSafe cppName hsType)++-- Specializations for different typeclasses ----------------------------------++data TypeClassSpec = TypeClassSpec+  { tySpec_classNm :: TypeQ+  , tySpec_functions :: [HsMethod]+  }++data HsMethod = HsMethod+  { hs_name :: String+  , hs_cppPrefix :: String+  , hs_typeFn :: TypeQ -> TypeQ+  }++destructSpec :: TypeClassSpec+destructSpec = TypeClassSpec+  { tySpec_classNm = [t| Destructible |]+  , tySpec_functions =+      [ HsMethod "destruct" "destructible_destruct"+          (\hsType -> [t| Ptr $hsType -> IO () |])+      , HsMethod "delete" "destructible_delete"+          (\hsType -> [t| Ptr $hsType -> IO () |])+      , HsMethod "deleteFunPtr" "&destructible_delete"+          (\hsType -> [t| FunPtr (Ptr $hsType -> IO ()) |])+      ]+  }++constructSpec :: TypeClassSpec+constructSpec = TypeClassSpec+  { tySpec_classNm = [t| DefaultConstructible |]+  , tySpec_functions =+      [ HsMethod "constructDefault" "constructible_constructDefault"+          (\hsType -> [t| Ptr $hsType -> IO () |])+      , HsMethod "newDefault" "constructible_newDefault"+          (\hsType -> [t| IO (Ptr $hsType) |])+      ]+  }++-- Common code ----------------------------------------------------------------++derive :: TypeClassSpec -> Safety -> String -> TypeQ -> Q [Dec]+derive TypeClassSpec{..} safety cppName hsType = do+  (funs, forImps) <- unzip <$> mapM gen tySpec_functions+  -- instance Destructible HsString where+  instD <- instanceD+    (cxt [])+    [t| $tySpec_classNm $hsType |]+    (map pure funs)+  return $ instD: forImps+  where+  gen :: HsMethod -> Q (Dec, Dec)+  gen HsMethod{..} = do+    hsTypeStr <- map (\i -> if isAlphaNum i then i else '_') . pprint <$> hsType+    let cppBinding = hs_cppPrefix ++ cppName+        hsBinding = mkName $ hs_name ++ hsTypeStr ++ show safety+    -- destruct = destructHsStructUnsafe+    fun <- funD (mkName hs_name)+      [ clause [] (normalB $ varE hsBinding) []+      ]+    -- foreign import ccall unsafe "destructible_destructCppStruct"+    --   destructHsStructUnsafe :: Ptr Hs -> IO ()+    forImp <- forImpD cCall safety cppBinding hsBinding $+      hs_typeFn hsType+    return (fun, forImp)
+ LICENSE view
@@ -0,0 +1,30 @@+BSD License++For hsthrift software++Copyright (c) Facebook, Inc. and its affiliates. All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++ * Neither the name Facebook nor the names of its contributors may be used to+   endorse or promote products derived from this software without specific+   prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Util/ASan.hs view
@@ -0,0 +1,106 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.ASan+  ( alloca+  , allocaBytes+  , allocaArray+  , allocaArray0+  , allocaBytesAligned+  , with+  , byteStringWithCString+  , byteStringWithCStringLen+  , textWithCStringLen+  , textWithCString+  , textUseAsPtr+  ) where++import Control.Exception++import Foreign hiding+  (alloca, allocaBytes, allocaBytesAligned, allocaArray, allocaArray0, with)+import Foreign.C++import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BI++import Data.Text.Internal (Text(..))+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text.Foreign as TF++import Util.FFI++-- The following functions already support ASan (they already allocate using+-- malloc):+-- newCStringFromText++alloca :: Storable a => (Ptr a -> IO b) -> IO b+alloca = doAlloca undefined+  where+    doAlloca :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b'+    doAlloca dummy = allocaBytesAligned (sizeOf dummy) (alignment dummy)++allocaBytes :: Int -> (Ptr a -> IO b) -> IO b+allocaBytes size = bracket (mallocBytes size) free++-- alignedAlloc calls an aligned allocation function that is platform-dependent+-- void *alignedAlloc( size_t alignment, size_t size );+foreign import ccall unsafe "alignedAlloc"+  cAlignedAlloc :: CSize -> CSize -> IO (Ptr a)++allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b+allocaBytesAligned size alignment =+  bracket (cAlignedAlloc (fromIntegral alignment) (fromIntegral size)) free++allocaArray :: Storable a => Int -> (Ptr a -> IO b) -> IO b+allocaArray  = doAlloca undefined+  where+    doAlloca :: Storable a' => a' -> Int -> (Ptr a' -> IO b') -> IO b'+    doAlloca dummy size = allocaBytesAligned (size * sizeOf dummy)+                                              (alignment dummy)++allocaArray0      :: Storable a => Int -> (Ptr a -> IO b) -> IO b+allocaArray0 size  = allocaArray (size + 1)++with :: Storable a => a -> (Ptr a -> IO b) -> IO b+with val f =+  alloca $ \ptr -> do+    poke ptr val+    f ptr++-- Text / ByteString marshalling++textWithCString :: Text -> (CString -> IO a) -> IO a+textWithCString = byteStringWithCString . encodeUtf8++byteStringWithCString :: BS.ByteString -> (CString -> IO a) -> IO a+byteStringWithCString (BI.PS fp off len) fun =+  allocaBytes (len+1) $ \ptr' -> do+    unsafeWithForeignPtr fp $ \ptr -> do+      copyBytes ptr' (ptr `plusPtr` off) len+      poke (ptr' `plusPtr` len) (0 :: Word8)+    fun ptr'+++textWithCStringLen :: Text -> (CStringLen -> IO a) -> IO a+textWithCStringLen = byteStringWithCStringLen . encodeUtf8++byteStringWithCStringLen :: BS.ByteString -> (CStringLen -> IO a) -> IO a+byteStringWithCStringLen (BI.PS _ _ 0) fun = fun (nullPtr, 0)+byteStringWithCStringLen (BI.PS fp off len) fun =+  allocaBytes len $ \ptr' -> do+    unsafeWithForeignPtr fp $ \ptr -> copyBytes ptr' (ptr `plusPtr` off) len+    fun (ptr', len)++-- Text marshalling++textUseAsPtr :: Text -> (Ptr Word16 -> TF.I16 -> IO a) -> IO a+textUseAsPtr t@(Text _arr _off len) action =+    allocaBytes (len * 2) $ \buf -> do+      TF.unsafeCopyToPtr t buf+      action (castPtr buf) (fromIntegral len)
+ Util/Aeson.hs view
@@ -0,0 +1,195 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++-- FromJSON instance below is an orphan (deliberately)+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE CPP #-}++module Util.Aeson+  ( toJSONText+  , toJSONByteString+  , cStringToObject+  , unsafeCStringToObject+  , unsafeCStringLenToObject+  , prettyJSON+  , parseValueStrict'+  , parseValueStrict+    -- * Backwards compatibility+  , ObjectKey+  , KeyMap+  , keyToText+  , keysToTexts+  , keyFromText+  , objectToList+  , objectFromList+  , objectKeys+  , objectToHashMap+  , objectFromHashMap+  , objectToHashMapText+  , objectFromHashMapText+  , emptyKeyMap+  , insertKeyMap+  , unionKeyMap+  , keyMapSize+  , lookupKeyMap+  ) where++import Data.Aeson+import Data.Aeson.Parser (value, value')+#if MIN_VERSION_aeson(2,0,0)+import Data.Aeson.Key+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Coerce+import Data.Type.Coercion+#endif+import Data.Aeson.Types (typeMismatch)+import Data.ByteString (ByteString)+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString.Char8 as A+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Lazy as LB+import Data.HashMap.Strict (HashMap)+import Data.Text (Text)+import Foreign.C++import Text.PrettyPrint+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Vector as Vector+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text++-- | Converts a value to JSON, and returns it as a 'Text'+toJSONText :: ToJSON x => x -> Text.Text+toJSONText = Text.decodeUtf8 . toJSONByteString++-- | Converts a value to JSON, and returns it as a 'ByteString'+toJSONByteString :: ToJSON x => x -> ByteString+toJSONByteString = LB.toStrict . encode++-- | Since Aeson is lazily parsed, this assumes that that the memory+-- pointed to in the 'CString' will live throughout the liftime of the+-- returned object. If not, this potentially references freed memory. If+-- you cannot guarantee the lifetime, use 'cStringToObject'.+unsafeCStringToObject :: CString -> IO (Maybe Object)+unsafeCStringToObject s = decodeStrict <$> B.unsafePackCString s++-- | like 'unsafeCStringToObject' but takes a length too+unsafeCStringLenToObject :: CString -> Int -> IO (Maybe Object)+unsafeCStringLenToObject s l = decodeStrict <$> B.unsafePackCStringLen (s,l)++-- | Copies the 'CString' contents into Haskell, and then creates a+-- lazily parsed Aeson 'Object'.+cStringToObject :: CString -> IO (Maybe Object)+cStringToObject s = decodeStrict <$> B.packCString s++-- | Convert a JSON value to a 'String' with indentation to make it+-- easier to read.+prettyJSON :: Value -> String+prettyJSON val = show (pp val)+ where+  pp :: Value -> Doc+  pp Null = text "null"+  pp (Bool b) = text $ if b then "true" else "false"+  pp (String txt) =+    text (Text.unpack $ Text.decodeUtf8 $ LB.toStrict $ encode (String txt))+  pp (Number i) = text (show i)+  pp (Object hm) =+    braces $ sep $+      punctuate (char ',')+        [ sep [ pp (String (keyToText key)) <+> char ':', nest 2 (pp v) ]+        | (key, v) <- HashMap.toList (objectToHashMap hm) ]+  pp (Array arr) =+    brackets $ sep $ punctuate (char ',') $ map pp $ Vector.toList arr++-- eitherDecode family of function  strictly requires that the Value is+-- either an object or an array.+-- This relaxes that restriction and allows other kinds of Values.+-- NOTE: this is fixed in latest aeson+parseValueStrict :: ByteString -> Either String Value+parseValueStrict = A.parseOnly+  (A.skipSpace *> value <* A.skipSpace <* A.endOfInput)++parseValueStrict' :: ByteString -> Either String Value+parseValueStrict' = A.parseOnly+  (A.skipSpace *> value' <* A.skipSpace <* A.endOfInput)++-- Orphan instance to make from/toJSON O(1) when converting from/to an Object+-- (aka HashMap Text Value).  Otherwise the default instances provided+-- by Aeson will rebuild the HashMap.+--+-- This needs to be not just OVERLAPPABLE, but INCOHERENT, because+-- otherwise a constraint "FromJSON (HashMap Text a)" doesn't have a+-- single most-specific instance to resolve to.  INCOHERENT is ok;+-- the worst that can happen is that we lose the optimisation.+instance {-# INCOHERENT #-} FromJSON Object where+  parseJSON (Object obj) = return obj+  parseJSON other = typeMismatch "object" other++-- Having same optimization for 'ToJSON' is still valuable when we cannot use+-- 'Object' directly, e.g., when we are calling a polymorphic function with+-- a @ToJSON a@ constraint.+instance {-# INCOHERENT #-} ToJSON Object where+  toJSON = Object++keyToText :: ObjectKey -> Text+keysToTexts :: [ObjectKey] -> [Text]  -- zero-cost coercion+keyFromText :: Text -> ObjectKey+objectToList :: KeyMap v -> [(ObjectKey, v)]+objectFromList :: [(ObjectKey, v)] -> KeyMap v+objectKeys :: KeyMap v -> [ObjectKey]+objectToHashMap :: KeyMap v -> HashMap ObjectKey v+objectFromHashMap :: HashMap ObjectKey Value -> Object+objectToHashMapText :: KeyMap v -> HashMap Text v+objectFromHashMapText :: HashMap Text v -> KeyMap v+emptyKeyMap :: KeyMap v+insertKeyMap :: ObjectKey -> v -> KeyMap v -> KeyMap v+unionKeyMap :: KeyMap v -> KeyMap v -> KeyMap v+keyMapSize :: KeyMap v -> Int+lookupKeyMap :: ObjectKey -> KeyMap v -> Maybe v++#if MIN_VERSION_aeson(2,0,0)+type ObjectKey = Key+type KeyMap = KeyMap.KeyMap+keyToText = toText+keysToTexts = case Key.coercionToText of+  Just Coercion -> coerce+  _ -> map keyToText+keyFromText = fromText+objectToList = KeyMap.toList+objectFromList = KeyMap.fromList+objectKeys = KeyMap.keys+objectToHashMap = KeyMap.toHashMap+objectFromHashMap = KeyMap.fromHashMap+objectToHashMapText = KeyMap.toHashMapText+objectFromHashMapText = KeyMap.fromHashMapText+emptyKeyMap = KeyMap.empty+insertKeyMap = KeyMap.insert+unionKeyMap = KeyMap.union+keyMapSize = KeyMap.size+lookupKeyMap = KeyMap.lookup+#else+type ObjectKey = Text+type KeyMap v = HashMap Text v+keyToText = id+keysToTexts = id+keyFromText = id+objectToList = HashMap.toList+objectFromList = HashMap.fromList+objectKeys = HashMap.keys+objectToHashMap = id+objectFromHashMap = id+objectToHashMapText = id+objectFromHashMapText = id+emptyKeyMap = HashMap.empty+insertKeyMap = HashMap.insert+unionKeyMap = HashMap.union+keyMapSize = HashMap.size+lookupKeyMap = HashMap.lookup+#endif
+ Util/AllocLimit.hs view
@@ -0,0 +1,118 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Util.AllocLimit+  ( limitAllocs+  , limitAllocsThrow+  , withAllocLimit+  , withSavedAllocLimit+  , withAllocCounter+  , handleAllExceptions+  ) where++import GHC.Conc+import Data.Int+import Control.Exception++-- | Impose an allocation limit on the given 'IO' action.  If the+-- action exceeds the limit, then 'Nothing' will be returned.+limitAllocs :: Int64 -> IO a -> IO (Maybe a)+limitAllocs limit action =+  handle (\AllocationLimitExceeded -> return Nothing) $+    Just <$> limitAllocsThrow limit action++-- | Impose an allocation limit on the given 'IO' action.  If the+-- action exceeds the limit, then 'AllocationLimitExceeded' will be+-- thrown.+limitAllocsThrow :: Int64 -> IO a -> IO a+limitAllocsThrow limit action = do+  e <- handleAllExceptions (return . Left) $+    Right <$> withSavedAllocLimit limit action+  either throwIO return e++-- | Impose an allocation limit on the given 'IO' action.  If the+-- action exceeds the limit, then 'AllocationLimitExceeded' will be+-- thrown. (Note: most uses should use 'limitAllocs' instead).+--+-- Note that if this function throws an exception+-- ('AllocationLimitExceeded' or otherwise), even though there will be+-- no /more/ 'AllocationLimitExceeded' exceptions, there might be+-- multiple 'AllocationLimitExceeded' exceptions already in flight.+-- This happens as follows: the first exception gets thrown, which+-- causes an exception handler to run, which triggers another+-- 'AllocationLimitExceeded' exception, which doesn't get thrown+-- immediately because the exception handler is implicitly masked, and+-- so on.+--+-- To deal with this we provide 'handleAllExceptions', which you+-- should wrap around 'withAllocLimit'.+--+-- Note: this function clobbers the allocation counter, so+-- e.g. `Util.Timing.timeIt` will give bogus results if the+-- computation being measured calls `withAllocLimit`. To avoid this,+-- use `withSavedAllocLimit` instead.+withAllocLimit :: Int64 -> IO a -> IO a+withAllocLimit limit =+  bracket_+    (do setAllocationCounter limit; enableAllocationLimit)+    disableAllocationLimit++-- | Like `withAllocLimit`, but does not clobber the allocation+-- counter.+withSavedAllocLimit :: Int64 -> IO a -> IO a+withSavedAllocLimit limit io = bracket set unset $ \_ -> io+  where+  set = do+    prev <- getAllocationCounter+    setAllocationCounter limit+    enableAllocationLimit+    return prev+  unset prev = do+    cur <- getAllocationCounter+    disableAllocationLimit+    setAllocationCounter (prev - (limit - cur))++-- | Sets the allocation counter for the given 'IO' action, then restores the+-- original counter value after the 'IO' action is done.+--+-- Note that as opposed to 'withAllocLimit' this function provides no guarantee+-- that if the set alloc counter is consumed, an 'AllocationLimitExceeded' will+-- be thrown, that depends on whether 'enableAllocationLimit' has been called+-- or not. If that guarantee is something you need, use 'withAllocLimit', but be+-- mindful of the fact that 'withAllocLimit' calls should not be nested inside+-- each other while 'withAllocCounter' calls can.+--+-- This function can be useful when there's a need to "isolate" certain+-- calls from the current allocation limit by setting a separate allocation+-- limit for them, then restoring the initial limit when done.+--+-- Once this is done: T30781590. We will be able to use the new primitive in+-- 'withAllocLimit' and deprecate 'withAllocCounter'+withAllocCounter :: Int64 -> IO a -> IO a+withAllocCounter counter action = do+  initialAllocCounter <- getAllocationCounter+  bracket_+    (setAllocationCounter counter)+    (setAllocationCounter initialAllocCounter)+    action++-- | Like 'Control.Exception.handle', but if there are pending async+-- exceptions, all are swallowed except for the last one, which is+-- passed to the handler.  This is mainly for wrapping around+-- 'withAllocLimit', to ensure that no 'AllocationLimitExceeded'+-- exceptions can leak out.+--+handleAllExceptions :: (SomeException -> IO a) -> IO a -> IO a+handleAllExceptions handler = handle errorHandler+  where+    errorHandler exn =+      handle errorHandler $ do+        allowInterrupt -- let any pending async exceptions throw+        handler exn
+ Util/Applicative.hs view
@@ -0,0 +1,14 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Applicative+  ( concatMapM+  ) where++concatMapM :: (Applicative f) => (a -> f [b]) -> [a] -> f [b]+concatMapM f = fmap concat . traverse f
+ Util/AsanAlloc.cpp view
@@ -0,0 +1,22 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#include "Util/AsanAlloc.h"++#include <malloc.h>++void* alignedAlloc(size_t alignment, size_t size) noexcept {+// GCC only supports ASAN aligned_alloc as of September 2014, which roughly+// corresponds to version 5 and above. This code can be deprecated once+// Facebook upgrade to GCC 5.x+#if __clang__ || __GNUC__ > 4+  return aligned_alloc(alignment, size);+#else+  return memalign(alignment, size);+#endif+}
+ Util/AsanAlloc.h view
@@ -0,0 +1,16 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++#include <stdlib.h>++extern "C" {++void* alignedAlloc(size_t alignment, size_t size) noexcept;+}
+ Util/Async.hs view
@@ -0,0 +1,63 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++-- | This module provides some higher level concurrency facilities+module Util.Async+  ( window_,+    windowUnorderedReduce,+    runHereOrConcurrently+  ) where++import Control.Concurrent.Async+import Control.Concurrent.Chan+import Control.Monad (forM_, replicateM_)++-- | This function is similar to folly::window. It takes a list of input items+--   and launch a pool of `maxConcurrency` of workers to process them+window_ :: Int -> (a -> IO ()) -> [a] -> IO ()+window_ maxConcurrency process tasks = do+  queue <- newChan+  forM_ tasks $ writeChan queue . Just+  replicateM_ maxConcurrency $ writeChan queue Nothing+  replicateConcurrently_ maxConcurrency $ runWorker queue process+  where+    runWorker :: Chan (Maybe a) -> (a -> IO ()) -> IO ()+    runWorker queue process' = do+      token <- readChan queue+      case token of+        Just task -> do+          process' task+          runWorker queue process'+        Nothing -> return ()+++-- | A variant of window function where we collect the result without+--   preserving the order+windowUnorderedReduce+  :: Monoid b => Int -> (a -> IO b) -> [a] -> IO [b]+windowUnorderedReduce maxConcurrency process tasks = do+  queue <- newChan+  forM_ tasks $ writeChan queue . Just+  replicateM_ maxConcurrency $ writeChan queue Nothing+  replicateConcurrently maxConcurrency+    $ runWorker queue mempty+  where+    runWorker queue acc = do+      token <- readChan queue+      case token of+        Just task -> do+          result <- process task+          runWorker queue $ mappend result acc+        Nothing -> return acc++-- | A wrapper for 'mapConcurrently' so that a singleton list of+-- actions runs in this thread, instead of asynchronously+runHereOrConcurrently :: [IO a] -> IO [a]+runHereOrConcurrently [] = return []+runHereOrConcurrently [x] = (:[]) <$> x+runHereOrConcurrently xs = mapConcurrently id xs
+ Util/Bag.hs view
@@ -0,0 +1,53 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Bag+  ( Bag -- Do not export constructors.+  , singleton+  , empty+  , fromList+  ) where++import Data.Foldable (toList)++-- | A bag of items which supports O(1) append+data Bag a+  = EmptyBag+  | OneItem a+  | ConcatBags (Bag a) (Bag a) -- INVARIANT: Neither sub-bag is empty++instance Semigroup (Bag a) where+  (<>) EmptyBag y = y+  (<>) x EmptyBag = x+  (<>) x y = ConcatBags x y++instance Monoid (Bag a) where+  mempty = EmptyBag++instance Foldable Bag where+  foldr _ b EmptyBag = b+  foldr f b (OneItem x) = f x b+  foldr f b (ConcatBags x y) = foldr f (foldr f b y) x++instance Functor Bag where+  fmap _ EmptyBag = EmptyBag+  fmap f (OneItem x) = OneItem $ f x+  fmap f (ConcatBags x y) = ConcatBags (fmap f x) (fmap f y)++singleton :: a -> Bag a+singleton x = OneItem x++empty :: Bag a -> Bool+empty EmptyBag = True+empty _ = False++fromList :: [a] -> Bag a+fromList = mconcat . map singleton++instance Show a => Show (Bag a) where+  show b = "fromList " ++ show (toList b)
+ Util/Binary/Parser.hs view
@@ -0,0 +1,505 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE Strict #-}++module Util.Binary.Parser+  ( Parser+  , parse+  , parseAndLeftover+  , peekBS+  , anyWord8+  , word8+  , getInt16be+  , getInt16le+  , getInt32be+  , getInt32le+  , getInt64be+  , getInt64le+  , getWord16be+  , getWord16le+  , getWord32be+  , getWord32le+  , getWord64be+  , getWord64le+  , skipN+  , skipSpaces+  , sepBy+  , string+  , signed+  , peek+  , double+  , decimal+  , getByteString+  , takeWhile+  ) where++import Control.Applicative+#if __GLASGOW_HASKELL__ == 806+import Control.Monad hiding (fail)+#else+import Control.Monad+#endif+#if __GLASGOW_HASKELL__ == 806+import Control.Monad.Fail as Fail+#endif+import Control.Exception+import Util.Control.Exception (tryAll)++import Data.Bits+import Data.ByteString (ByteString)+import Data.ByteString.Unsafe as B+import qualified Data.ByteString as B+import qualified Data.ByteString.Lex.Integral as LexInt+import Data.Scientific (Scientific (..))+import qualified Data.Scientific as Sci+import Data.Word++#if __GLASGOW_HASKELL__ >= 902+import GHC.Data.FastMutInt+#else+import FastMutInt+#endif++#if __GLASGOW_HASKELL__ == 806+import GHC.Base hiding (fail)+#else+import GHC.Base+#endif+import GHC.Word+import GHC.Int++#if __GLASGOW_HASKELL__ == 806+import Prelude hiding (takeWhile, fail)+#else+import Prelude hiding (takeWhile)+#endif++import System.IO.Unsafe (unsafeDupablePerformIO)++data Env = Env {-# UNPACK #-} !ByteString+               {-# UNPACK #-} !FastMutInt++newtype Parser a = Parser { unParser :: Env -> IO a }++instance Functor Parser where+  fmap f m = Parser $ \env -> do+    a <- unParser m env+    return $ f a+  {-# INLINE fmap #-}++instance Applicative Parser where+  pure a = Parser $ \_ -> return a+  (<*>) = ap+  {-# INLINE (<*>) #-}++instance Alternative Parser where+  empty = Parser $ \_ -> throwIO $+    ParseError "Thrift.Binary.Parser(Alternative).empty"+  (<|>) f g = Parser $ \env@(Env _ mutPos) -> do+    originalPos <- readFastMutInt mutPos+    eitherA <- tryAll $ unParser f env+    case eitherA of+      Right a -> return a+      Left _ -> do+        writeFastMutInt mutPos originalPos+        unParser g env++newtype ParseError = ParseError String deriving Show++instance Exception ParseError++instance Monad Parser where+    m >>= k = Parser $ \env -> do+      a <- unParser m env+      unParser (k a) env+    {-# INLINE (>>=) #-}++#if __GLASGOW_HASKELL__ > 804+instance MonadFail Parser where+#endif+    fail err = Parser $ \ (Env _ mutPos) -> do+      pos <- readFastMutInt mutPos+      throwIO $ ParseError+        $ err ++ ". Failed reading at byte position " ++ show pos++get :: Parser ByteString+get = Parser $ \(Env bs mutPos) -> do+  pos <- readFastMutInt mutPos+  return $ B.unsafeDrop pos bs++getAndIncrementMutPos :: FastMutInt -> Int -> IO Int+getAndIncrementMutPos mutPos nBytes = do+  pos <- readFastMutInt mutPos+  writeFastMutInt mutPos (pos + nBytes)+  return pos+{-# INLINE getAndIncrementMutPos #-}++incrPos :: Int -> Parser ()+incrPos nBytes= Parser $ \(Env _ mutPos) -> void $+  getAndIncrementMutPos mutPos nBytes++parse :: Parser a -> ByteString -> Either String a+parse getter bs =+  let+    eitherA = unsafeDupablePerformIO $ do+#if __GLASGOW_HASKELL__ >= 902+      mutPos <- newFastMutInt 0+#else+      mutPos <- newFastMutInt+      writeFastMutInt mutPos 0+#endif+      tryAll $ unParser getter $ Env bs mutPos in+  case eitherA of+    Right a -> Right a+    Left err -> Left (show err)++parseAndLeftover+  :: Parser a -> ByteString -> Either String (a, ByteString)+parseAndLeftover p bs = parse p' bs+  where p' = (,) <$> p <*> peekBS++peekBS :: Parser ByteString+peekBS = get++ensureN :: Int -> Parser Int+ensureN nBytes+  | nBytes < 0 = fail $ "negative byte count: " ++ show nBytes+  | otherwise = Parser $ \(Env bs mutPos) -> do+      pos <- readFastMutInt mutPos+      unless (nBytes <= B.length bs - pos) $+        fail "incomplete input"+      return pos+{-# INLINE ensureN #-}++anyWord8 :: Parser Word8+anyWord8 = do+  pos <- ensureN 1+  Parser $ \(Env bs mutPos) -> do+    writeFastMutInt mutPos (pos + 1)+    return $ B.unsafeIndex bs pos+{-# INLINE anyWord8 #-}++getByteString :: Int -> Parser ByteString+getByteString nBytes = do+  pos <- ensureN nBytes+  Parser $ \(Env bs mutPos) -> do+    writeFastMutInt mutPos (pos + nBytes)+    return $ B.unsafeTake nBytes (B.unsafeDrop pos bs)+{-# INLINE getByteString #-}++readN :: Int -> (ByteString -> a) -> Parser a+readN n f = f <$> getByteString n+{-# INLINE [0] readN #-}++skipN :: Int -> Parser ()+skipN nBytes = do+  pos <- ensureN nBytes+  Parser $ \(Env _ mutPos) -> writeFastMutInt mutPos (pos + nBytes)++peek :: Parser Word8+peek = do+  pos <- ensureN 1+  Parser $ \(Env bs _) ->+    return $ B.unsafeIndex bs pos+{-# INLINE peek #-}++word8 :: Word8 -> Parser ()+word8 w8 = do+  myW8 <- anyWord8+  when (myW8 /= w8) $+    fail "word8"+{-# INLINE word8 #-}++takeWhile :: (Word8 -> Bool) -> Parser ByteString+takeWhile p = do+  bs <- get+  let (want, _) = B.span p bs+  incrPos $ B.length want+  return want+{-# INLINE takeWhile #-}++isSpace :: Word8 -> Bool+isSpace w = w == 32 || w - 9 <= 4+{-# INLINE isSpace #-}++skipSpaces :: Parser ()+skipSpaces = do+  bs <- get+  let rest = B.dropWhile isSpace bs+  incrPos $ B.length bs - B.length rest++string :: ByteString -> Parser ()+string bs = do+  let l = B.length bs+  myBs <- getByteString l+  when (myBs /= bs) $+    fail "string"+{-# INLINE string #-}+++-- | The parser @satisfy p@ succeeds for any byte for which the+-- predicate @p@ returns 'True'. Returns the byte that is actually+-- parsed.+--+-- >digit = satisfy isDigit+-- >    where isDigit w = w >= 48 && w <= 57+--+satisfy :: (Word8 -> Bool) -> Parser Word8+satisfy p = do+  w8 <- anyWord8+  unless (p w8) $+    fail "satisfy"+  return w8+{-# INLINE satisfy #-}++-- | Similar to 'takeWhile', but requires the predicate to succeed on at least+-- one byte of input: it will fail if the predicate never returns 'True' or+-- reach the end of input+--+takeWhile1 :: (Word8 -> Bool) -> Parser ByteString+takeWhile1 p = do+    bs <- takeWhile p+    if B.null bs then fail "takeWhile1" else return bs+{-# INLINE takeWhile1 #-}+++#define  MINUS    45+#define  PLUS     43+#define  LITTLE_E 101+#define  BIG_E    69+#define  DOT      46++-- | Parse a number with an optional leading @\'+\'@ or @\'-\'@ sign+-- character.+--+signed :: Num a => Parser a -> Parser a+signed p = do+  w <- peek+  if w == MINUS+    then skipN 1 >> negate <$> p+    else if w == PLUS then skipN 1 >> p else p+{-# SPECIALISE signed :: Parser Int -> Parser Int #-}+{-# SPECIALISE signed :: Parser Int8 -> Parser Int8 #-}+{-# SPECIALISE signed :: Parser Int16 -> Parser Int16 #-}+{-# SPECIALISE signed :: Parser Int32 -> Parser Int32 #-}+{-# SPECIALISE signed :: Parser Int64 -> Parser Int64 #-}+{-# SPECIALISE signed :: Parser Integer -> Parser Integer #-}++-- | Decimal digit predicate.+--+isDigit :: Word8 -> Bool+isDigit w = w - 48 <= 9+{-# INLINE isDigit #-}++-- | Parse and decode an unsigned decimal number.+--+decimal :: Integral a => Parser a+decimal = do+    bs <- takeWhile1 isDigit+    return $! LexInt.readDecimal_ bs+{-# SPECIALISE decimal :: Parser Int #-}+{-# SPECIALISE decimal :: Parser Int8 #-}+{-# SPECIALISE decimal :: Parser Int16 #-}+{-# SPECIALISE decimal :: Parser Int32 #-}+{-# SPECIALISE decimal :: Parser Int64 #-}+{-# SPECIALISE decimal :: Parser Integer #-}+{-# SPECIALISE decimal :: Parser Word #-}+{-# SPECIALISE decimal :: Parser Word8 #-}+{-# SPECIALISE decimal :: Parser Word16 #-}+{-# SPECIALISE decimal :: Parser Word32 #-}+{-# SPECIALISE decimal :: Parser Word64 #-}++double :: Parser Double+double = scientifically Sci.toRealFloat++-- | Parse a scientific number and convert to result using a user supply+-- function.+--+-- The syntax accepted by this parser is the same as for 'double'.+--+scientifically :: (Scientific -> a) -> Parser a+scientifically h = do+    sign <- peek+    when (sign == PLUS || sign == MINUS) (skipN 1)+    intPart <- decimal+    sci <- (do fracDigits <- word8 DOT >> takeWhile1 isDigit+               let e' = B.length fracDigits+                   intPart' = intPart * (10 ^ e')+                   fracPart = LexInt.readDecimal_ fracDigits+               parseE (intPart' + fracPart) e'+           ) <|> parseE intPart 0++    if sign /= MINUS then return $! h sci else return $! h (negate sci)+  where+    parseE c e =+        (do _ <- satisfy (\w -> w ==  LITTLE_E || w == BIG_E)+            Sci.scientific c . subtract e <$> signed decimal)+        <|> return (Sci.scientific c (negate e))+    {-# INLINE parseE #-}+{-# INLINE scientifically #-}++sepBy :: Alternative f => f a -> f s -> f [a]+sepBy p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure []) <|> pure []+{-# SPECIALIZE sepBy :: Parser a -> Parser s -> Parser [a] #-}++sepBy1 :: Alternative f => f a -> f s -> f [a]+sepBy1 p s = go+    where go = liftA2 (:) p ((s *> go) <|> pure [])+{-# SPECIALIZE sepBy1 :: Parser a -> Parser s -> Parser [a] #-}++------------------------------------------------------------------------+-- Following code is copied from Data.Binary.Get+------------------------------------------------------------------------+type Get a = Parser a++-- force GHC to inline getWordXX+{-# RULES+"getWord16be/readN" getWord16be = readN 2 word16be+"getWord16le/readN" getWord16le = readN 2 word16le+"getWord32be/readN" getWord32be = readN 4 word32be+"getWord32le/readN" getWord32le = readN 4 word32le+"getWord64be/readN" getWord64be = readN 8 word64be+"getWord64le/readN" getWord64le = readN 8 word64le #-}++-- | Read a Word16 in big endian format+getWord16be :: Get Word16+getWord16be = readN 2 word16be++word16be :: B.ByteString -> Word16+word16be = \s ->+        (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w16` 8) .|.+        (fromIntegral (s `B.unsafeIndex` 1))+{-# INLINE[2] getWord16be #-}+{-# INLINE word16be #-}++-- | Read a Word16 in little endian format+getWord16le :: Get Word16+getWord16le = readN 2 word16le++word16le :: B.ByteString -> Word16+word16le = \s ->+              (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w16` 8) .|.+              (fromIntegral (s `B.unsafeIndex` 0) )+{-# INLINE[2] getWord16le #-}+{-# INLINE word16le #-}++-- | Read a Word32 in big endian format+getWord32be :: Get Word32+getWord32be = readN 4 word32be++word32be :: B.ByteString -> Word32+word32be = \s ->+              (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w32` 24) .|.+              (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 16) .|.+              (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32`  8) .|.+              (fromIntegral (s `B.unsafeIndex` 3) )+{-# INLINE[2] getWord32be #-}+{-# INLINE word32be #-}++-- | Read a Word32 in little endian format+getWord32le :: Get Word32+getWord32le = readN 4 word32le++word32le :: B.ByteString -> Word32+word32le = \s ->+              (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w32` 24) .|.+              (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 16) .|.+              (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32`  8) .|.+              (fromIntegral (s `B.unsafeIndex` 0) )+{-# INLINE[2] getWord32le #-}+{-# INLINE word32le #-}++-- | Read a Word64 in big endian format+getWord64be :: Get Word64+getWord64be = readN 8 word64be++word64be :: B.ByteString -> Word64+word64be = \s ->+              (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w64` 56) .|.+              (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 48) .|.+              (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 40) .|.+              (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 32) .|.+              (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 24) .|.+              (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 16) .|.+              (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64`  8) .|.+              (fromIntegral (s `B.unsafeIndex` 7) )+{-# INLINE[2] getWord64be #-}+{-# INLINE word64be #-}++-- | Read a Word64 in little endian format+getWord64le :: Get Word64+getWord64le = readN 8 word64le++word64le :: B.ByteString -> Word64+word64le = \s ->+              (fromIntegral (s `B.unsafeIndex` 7) `shiftl_w64` 56) .|.+              (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 48) .|.+              (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 40) .|.+              (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 32) .|.+              (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 24) .|.+              (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 16) .|.+              (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64`  8) .|.+              (fromIntegral (s `B.unsafeIndex` 0) )+{-# INLINE[2] getWord64le #-}+{-# INLINE word64le #-}++-- | Read an Int16 in big endian format.+getInt16be :: Get Int16+getInt16be = fromIntegral <$> getWord16be+{-# INLINE getInt16be #-}++-- | Read an Int32 in big endian format.+getInt32be :: Get Int32+getInt32be =  fromIntegral <$> getWord32be+{-# INLINE getInt32be #-}++-- | Read an Int64 in big endian format.+getInt64be :: Get Int64+getInt64be = fromIntegral <$> getWord64be+{-# INLINE getInt64be #-}++-- | Read an Int16 in little endian format.+getInt16le :: Get Int16+getInt16le = fromIntegral <$> getWord16le+{-# INLINE getInt16le #-}++-- | Read an Int32 in little endian format.+getInt32le :: Get Int32+getInt32le =  fromIntegral <$> getWord32le+{-# INLINE getInt32le #-}++-- | Read an Int64 in little endian format.+getInt64le :: Get Int64+getInt64le = fromIntegral <$> getWord64le+{-# INLINE getInt64le #-}++------------------------------------------------------------------------+-- Unchecked shifts+shiftl_w16 :: Word16 -> Int -> Word16+#if __GLASGOW_HASKELL__ >= 902+shiftl_w16 (W16# w) (I# i) = W16# (wordToWord16# (word16ToWord# w `uncheckedShiftL#` i))+#else+shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)+#endif++shiftl_w32 :: Word32 -> Int -> Word32+#if __GLASGOW_HASKELL__ >= 902+shiftl_w32 (W32# w) (I# i) = W32# (wordToWord32# (word32ToWord# w `uncheckedShiftL#` i))+#else+shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)+#endif++shiftl_w64 :: Word64 -> Int -> Word64+#if WORD_SIZE_IN_BITS < 64+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)+#else+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)+#endif
+ Util/Bits.hs view
@@ -0,0 +1,28 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE MagicHash #-}+module Util.Bits (bitLength) where++import GHC.Exts+import GHC.Integer.Logarithms++-- | The number of bits in the minimal two's-complement+-- representation, excluding a sign bit.+--+-- > bitLength 3 = 2+-- > bitLength 4 = 3+--+-- See http://mathworld.wolfram.com/BitLength.html for more information.+bitLength :: Integral a => a -> Int+bitLength = integerBitLength . toInteger+  where+  integerBitLength n+    | n < 0 = integerBitLength $ -1 - n+    | n == 0 = 0+    | otherwise = I# (1# +# integerLog2# n)
+ Util/Buffer.hs view
@@ -0,0 +1,233 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE CPP       #-}+{-# LANGUAGE MagicHash #-}++-- | Byte buffers in ST with amortized O(1) append. They are significantly+-- faster and more memory efficient than things built on top of lazy+-- bytestrings.++module Util.Buffer+  ( Buffer, Fill+  , liftST+  , alloc+  , ascii+  , byte+  , byteString+  , fillByteString+  )+where++import Control.Exception (assert)+import Control.Monad.Primitive+import Control.Monad.ST (ST)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Internal as BSI+import Data.Char (isAscii)+#if !MIN_VERSION_primitive(0,7,0)+import Data.Primitive.Addr (Addr(..))+#endif+import Data.Primitive.ByteArray+import GHC.Exts+  ( Int(..), plusAddr#+  , copyAddrToByteArray#, shrinkMutableByteArray#+  , unsafeCoerce#+  )+import GHC.ForeignPtr+import GHC.Ptr (Ptr(..), plusPtr)+import GHC.Word (Word8(..))++-- | An exponentially growing buffer of bytes in ST with amortized O(1) append.+--+-- Invariants:+--+-- > bufLen buf <= bufRes buf+-- > bufRes buf <= bufCap buf+-- > bufCap buf > 0+--+data Buffer s = Buffer+  { -- | The actual bytes+    bufData :: {-# UNPACK #-} !(MutableByteArray s)++    -- | How much of the buffer has been filled+  , bufLen :: {-# UNPACK #-} !Int++    -- | How much of the buffer has been reserved+  , bufRes :: {-# UNPACK #-} !Int++    -- | Capacity of the buffer (i.e., length of the MutableByteArray)+  , bufCap :: {-# UNPACK #-} !Int+  }++-- | An ST-based monad for filling.+data Fill s a = Fill+  { -- | How many bytes to reserve - _fillIt assumes that the Buffer will have+    -- at least that much free space. This helps avoid repeated calls to+    -- 'reserve'.+    _fillRes :: {-# UNPACK #-} !Int++    -- | The function that fills the Buffer. The old Buffer may not be used+    -- after this function has been invoked.+  , _fillIt :: Buffer s -> ST s (Buffer s, a)+  }++instance Functor (Fill s) where+  {-# INLINE fmap #-}+  fmap f (Fill n h) = Fill n $ fmap (fmap (fmap f)) h++instance Applicative (Fill s) where+  {-# INLINE pure #-}+  pure x = Fill 0 $ \ !buf -> return (buf, x)++  {-# INLINE (*>) #-}+  Fill m f *> Fill n g = Fill (m+n) $ \ !buf -> do+    (!buf,_) <- f buf+    g buf++  {-# INLINE (<*>) #-}+  Fill m f <*> Fill n g = Fill (m+n) $ \ !buf -> do+    (!buf, h) <- f buf+    (!buf, x) <- g buf+    return (buf, h x)++instance Monad (Fill s) where+  {-# INLINE return #-}+  return = pure++  {-# INLINE (>>=) #-}+  Fill m f >>= g = Fill m $ \ !buf -> do+    (!buf, x) <- f buf+    fill buf $ g x++-- | Fill a buffer. The old buffer may not be used after this.+fill :: Buffer s -> Fill s a -> ST s (Buffer s, a)+{-# INLINE fill #-}+fill !buf (Fill n f) = do+  buf <- reserve buf n+  f buf++-- | Lift 'ST' actions into 'Fill'.+liftST :: ST s a -> Fill s a+{-# INLINE liftST #-}+liftST st = Fill 0 $ \ !buf -> (,) buf <$> st++-- | Write into the buffer.+write+  :: Int -- ^ max number of bytes to write+  -> (MutableByteArray s -> Int -> ST s Int)+    -- ^ takes the raw array and an initial offset and returns the offset+    -- one past the last byte it wrote+  -> Fill s ()+{-# INLINE write #-}+write n f = Fill n $ \(Buffer arr len res cap) -> do+  len' <- f arr len+  return (Buffer arr len' res cap, ())++-- | Write an ASCII (<=127) character into the buffer.+ascii :: Char -> Fill s ()+{-# INLINE ascii #-}+ascii c = assert (isAscii c) $ byte $ fromIntegral $ fromEnum c++-- | Write a byte into the buffer.+byte :: Word8 -> Fill s ()+{-# INLINE byte #-}+byte !x = write 1 $ \arr i -> do+  writeByteArray arr i x+  return (i+1)++-- | Write a 'ByteString' into the buffer.+byteString :: ByteString -> Fill s ()+{-# INLINE byteString #-}+byteString (BSI.PS (ForeignPtr addr# r) (I# k#) n@(I# n#)) =+  write n $ \(MutableByteArray arr#) i@(I# i#) -> do+    -- primitive doesn't wrap this so no point in trying to make things nice+    primitive_ (copyAddrToByteArray# (plusAddr# addr# k#) arr# i# n#)+    touch r+    return (i+n)++-- | Write into the buffer using a pointer. Writing more than the max number of+-- bytes will cause segfaults!+alloc+  :: Int -- ^ max number of bytes to write+  -> (forall s. Ptr Word8 -> ST s Int)+    -- ^ takes a pointer to the free space and returns the number of bytes+    -- written+  -> Fill s ()+{-# INLINE alloc #-}+alloc !n f = write n $ \arr i -> do+#if MIN_VERSION_primitive(0,7,0)+  let p = mutableByteArrayContents arr+  k <- f (p `plusPtr` i)+#else+  let !(Addr addr#) = mutableByteArrayContents arr+  k <- f (Ptr addr# `plusPtr` i)+#endif+  assert (k <= n) $ return ()+  touch arr+  return (i+k)++-- | Fill a buffer and turn it into a 'ByteString'.+fillByteString+  :: Int -- ^ initial capacity+  -> Fill s () -- ^ data+  -> ST s ByteString+{-# INLINE fillByteString #-}+fillByteString n f = do+  buf <- new n+  (buf, _) <- fill buf f+  unsafeFreezeByteString buf++-- | Create a new buffer with the given initial capacity.+new :: Int -> ST s (Buffer s)+new !cap = do+  let !c = max cap 1+  arr <- newPinnedByteArray c+  return Buffer+    { bufData = arr+    , bufLen = 0+    , bufRes = 0+    , bufCap = c+    }++reserve :: Buffer s -> Int -> ST s (Buffer s)+reserve (Buffer arr len res cap) !n+  | wanted <= cap = return $ Buffer arr len wanted cap+  | otherwise = do+      let !bcap = cap + max cap (wanted - cap)+      brr <- resize arr len bcap+      return $ Buffer brr len wanted bcap+  where+    !wanted = res + n++unsafeFreezeByteString :: Buffer s -> ST s ByteString+unsafeFreezeByteString (Buffer arr@(MutableByteArray arr#) len _ _) = do+  shrink arr len+  case mutableByteArrayContents arr of+#if MIN_VERSION_primitive(0,7,0)+    Ptr addr# ->+#else+    Addr addr# ->+#endif+      return $ BSI.fromForeignPtr+        (ForeignPtr addr# (PlainPtr (unsafeCoerce# arr#)))+        0+        len++resize :: MutableByteArray s -> Int -> Int -> ST s (MutableByteArray s)+{-# INLINE resize #-}+resize arr len cap = do+  brr <- newPinnedByteArray cap+  copyMutableByteArray brr 0 arr 0 len+  return brr++shrink :: MutableByteArray s -> Int -> ST s ()+shrink (MutableByteArray arr#) (I# n#) =+  -- shrinkMutableByteArray isn't wrapped by primitive+  -- NOTE: we assume that shrinking never unpins+  primitive_ (shrinkMutableByteArray# arr# n#)
+ Util/Build.hs view
@@ -0,0 +1,13 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Build+  ( Build+  ) where++type Build a = a -> a
+ Util/ByteString.hs view
@@ -0,0 +1,126 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# OPTIONS_GHC -fno-warn-unused-imports #-}++{-# LANGUAGE CPP #-}++module Util.ByteString+  ( newCStringFromLazyByteString+  , useLazyByteStringAsCString+  , intToByteString+  , useAsCString+  , useAsCStringLen+  , useByteStringsAsCStrings+  , bsListAsCStrLenArr+  , unsafeBsListAsCStrLenArr+  ) where++import Control.Arrow (left, second)+import Control.Monad+import qualified Data.ByteString.Unsafe as BS+import qualified Data.ByteString as BS+import Foreign+import Foreign.C++import Data.ByteString.Builder+import Data.ByteString.Builder.Extra+import qualified Data.ByteString as Strict+import qualified Data.ByteString.Lazy as Lazy+import qualified Data.Attoparsec.ByteString.Char8 as Atto+import qualified Data.Text as Text++import qualified Util.ASan as ASan++-- | Uses a lazy 'ByteString' as a NUL-terminated 'CString'.+useLazyByteStringAsCString+  :: Lazy.ByteString -> (CString -> IO a) -> IO a+useLazyByteStringAsCString = allocateAndCopy allocaBytes++-- | Copies a lazy 'ByteString' and adds a terminating NUL. The+-- resulting 'CString' must be 'free'd.+newCStringFromLazyByteString :: Lazy.ByteString -> IO CString+newCStringFromLazyByteString = flip (allocateAndCopy mallocBytes') return++useAsCStringLen :: BS.ByteString -> (CStringLen -> IO a) -> IO a+-- TODO(T24195918): We need to do this for ABI compatibility between+-- sigma.service and sigma.service.asan. Codemod to __SANITIZE_ADDRESS__+-- to enable ASAN checks for Haskell allocations.+#ifdef __HASKELL_SANITIZE_ADDRESS__+useAsCStringLen = ASan.byteStringWithCStringLen+#else+useAsCStringLen = BS.useAsCStringLen+#endif++useAsCString :: BS.ByteString -> (CString -> IO a) -> IO a+#ifdef __HASKELL_SANITIZE_ADDRESS__+useAsCString = ASan.byteStringWithCString+#else+useAsCString = BS.useAsCString+#endif++-- | Allocates space for a lazy 'ByteString' and NUL terminator, then+-- copies all its chunks into the buffer.+allocateAndCopy+  :: (Int -> (CString -> IO b) -> IO b)+  -> Lazy.ByteString+  -> (CString -> IO b)+  -> IO b+allocateAndCopy allocate lbs action = allocate (len + 1) $ \dst -> do+  copyChunksTo dst lbs+  pokeByteOff dst len (0::CChar)+  action dst++  where+  len :: Int+  len = fromIntegral (Lazy.length lbs)++  copyChunksTo :: Ptr a -> Lazy.ByteString -> IO ()+  copyChunksTo dst = foldM_ copyChunkTo 0 . Lazy.toChunks+    where+    copyChunkTo :: Int -> Strict.ByteString -> IO Int+    copyChunkTo off bs = BS.unsafeUseAsCStringLen bs $ \(src, chunkLen) -> do+      copyBytes (dst `plusPtr` off) src chunkLen+      return (off + chunkLen)++mallocBytes' :: Int -> (Ptr a -> IO b) -> IO b+mallocBytes' size action = mallocBytes size >>= action++lengthMinInt :: Int+lengthMinInt = length . show $ (minBound :: Int)++-- | Cheap (fast, low memory) conversion of Ints into an+-- ASCII/UTF8-encoded lazy ByteString.+intToByteString :: Int -> Lazy.ByteString+intToByteString =+  toLazyByteStringWith (untrimmedStrategy lengthMinInt 0) Lazy.empty . intDec++useByteStringsAsCStrings :: [BS.ByteString] -> (Ptr CString -> IO a) -> IO a+useByteStringsAsCStrings bs f = go bs []+  where go (t:ts) acc = useAsCString t $ go ts . (:acc)+        go []     acc = withArray0 nullPtr (reverse acc) f++bsListAsCStrLenArr :: [BS.ByteString]+                   -> (Ptr CString -> Ptr CSize -> CSize -> IO a)+                   -> IO a+bsListAsCStrLenArr bs f = go bs []+  where go (t:ts) acc = useAsCStringLen t $ go ts . (:acc)+        go []     acc = withArrayLen strs $ \len strPtr ->+                        withArray lens $ \lenPtr ->+                            f strPtr lenPtr (fromIntegral len)+            where (strs, lens) = second (map fromIntegral) $ unzip $ reverse acc++unsafeBsListAsCStrLenArr :: [BS.ByteString]+                   -> (Ptr CString -> Ptr CSize -> CSize -> IO a)+                   -> IO a+unsafeBsListAsCStrLenArr bs f = go bs []+  where go (t:ts) acc = BS.unsafeUseAsCStringLen t $ go ts . (:acc)+        go []     acc = withArrayLen strs $ \len strPtr ->+                        withArray lens $ \lenPtr ->+                            f strPtr lenPtr (fromIntegral len)+            where (strs, lens) = second (map fromIntegral) $ unzip $ reverse acc
+ Util/Concurrent.hs view
@@ -0,0 +1,103 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE CPP #-}+module Util.Concurrent+  ( concurrently3+  , concurrently4+  , concurrently5+  , concurrently6+  , concurrently7+  -- * ThreadLock+  , ThreadLock+  , newThreadLock+  , withThreadLock+  -- * Caching+  , cacheSuccess+  ) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Monad (void)+import Control.Monad.IO.Class++#if __GLASGOW_HASKELL__ >= 902+import Control.Monad.Catch+#else+import Exception (ExceptionMonad(..))+#endif++c :: IO a -> IO b -> IO (a, b)+c = concurrently++concurrently3 :: IO t1 -> IO t2 -> IO t3 -> IO (t1, t2, t3)+concurrently3 a1 a2 a3 = flatten3 <$> a1 `c` a2 `c` a3++concurrently4 :: IO t1 -> IO t2 -> IO t3 -> IO t4 -> IO (t1, t2, t3, t4)+concurrently4 a1 a2 a3 a4 = flatten4 <$> a1 `c` a2 `c` a3 `c` a4++concurrently5 :: IO t1 -> IO t2 -> IO t3 -> IO t4 -> IO t5+              -> IO (t1, t2, t3, t4, t5)+concurrently5 a1 a2 a3 a4 a5 = flatten5 <$> a1 `c` a2 `c` a3 `c` a4 `c` a5++concurrently6 :: IO t1 -> IO t2 -> IO t3 -> IO t4 -> IO t5 -> IO t6+              -> IO (t1, t2, t3, t4, t5, t6)+concurrently6 a1 a2 a3 a4 a5 a6 =+  flatten6 <$> a1 `c` a2 `c` a3 `c` a4 `c` a5 `c` a6++concurrently7 :: IO t1 -> IO t2 -> IO t3 -> IO t4 -> IO t5 -> IO t6 -> IO t7+              -> IO (t1, t2, t3, t4, t5, t6, t7)+concurrently7 a1 a2 a3 a4 a5 a6 a7 =+  flatten7 <$> a1 `c` a2 `c` a3 `c` a4 `c` a5 `c` a6 `c` a7++flatten3 ((a1, a2), a3) = (a1, a2, a3)+flatten4 (((a1, a2), a3), a4) = (a1, a2, a3, a4)+flatten5 ((((a1, a2), a3), a4), a5) = (a1, a2, a3, a4, a5)+flatten6 (((((a1, a2), a3), a4), a5), a6) = (a1, a2, a3, a4, a5, a6)+flatten7 ((((((a1, a2), a3), a4), a5), a6), a7) = (a1, a2, a3, a4, a5, a6, a7)++newtype ThreadLock = ThreadLock (IO (IO ()))++newThreadLock :: IO ThreadLock+newThreadLock = do+  mvar <- newEmptyMVar+  return $ ThreadLock $ do+    ours <- myThreadId+    theirs <- tryReadMVar mvar+    if theirs == Just ours+    then return $ return () -- we are holding the lock, so this is noop+    else do+      putMVar mvar ours+      return $ void $ takeMVar mvar++-- | withThreadLock guarantees that only one thread holds the lock at the same+-- time. It can be nested so it is safe to use it in a recursive function.+#if __GLASGOW_HASKELL__ >= 902+withThreadLock :: (MonadIO m, MonadMask m) => ThreadLock -> m a -> m a+withThreadLock (ThreadLock takeIO) action = do+  fmap fst $ generalBracket (liftIO takeIO) (\releaseIO _ -> liftIO releaseIO) $ const action+#else+withThreadLock :: ExceptionMonad m => ThreadLock -> m a -> m a+withThreadLock (ThreadLock takeIO) action = do+  gbracket (liftIO takeIO) (\releaseIO -> liftIO releaseIO) $ const action+#endif++-- | Build an IO action that will cache its result the first time it+-- runs successfullly to completion. If it fails with an exception,+-- the exception is re-raised, but the IO action will be attempted+-- again the next time it is invoked.+--+-- Like `Control.Concurrent.Extra.once`, but without caching exceptions.+--+cacheSuccess :: IO a -> IO (IO a)+cacheSuccess act = do+  m <- newMVar Nothing+  return $ modifyMVar m $ \x -> case x of+    Nothing -> do a <- act; return (Just a, a)+    Just a -> return (Just a, a)
+ Util/Control/Exception.hs view
@@ -0,0 +1,141 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Util.Control.Exception+  ( -- * Catching all exceptions safely+    catchAll+  , handleAll+  , tryAll+    -- * Exception predicates+  , isSyncException+  , isAsyncException+    -- * Other utilities+  , throwLeftIO+  , throwLeftExceptionIO+  , tryBracket+  , tryFinally+  , onSomeException+  , afterwards+  , swallow+  , logExceptions+  ) where++#if __GLASGOW_HASKELL__ == 804+import Control.Exception ( SomeAsyncException(..) )+#endif+import Control.Exception.Lifted+import Control.Monad+import Control.Monad.Trans.Control++import GHC.Stack (HasCallStack, withFrozenCallStack)++import Util.Log++-- | Catch all exceptions *except* asynchronous exceptions+-- (technically, children of 'SomeAsyncException').  Catching+-- asynchronous exceptions is almost never what you want to do: it can+-- result in ignoring 'ThreadKilled' which can lead to deadlock (see+-- <https://our.internmc.facebook.com/intern/diff/D4745709/+-- D4745709>).+--+-- Use this instead of the raw 'catch' when catching 'SomeException'.+--+catchAll :: MonadBaseControl IO m => m a -> (SomeException -> m a) -> m a+catchAll action handler =+  action `catch` \ex ->+    case fromException ex of+      Just (_ :: SomeAsyncException) -> throwIO ex+      Nothing -> handler ex++-- | The "try" version of 'catchAll'+tryAll :: MonadBaseControl IO m => m a -> m (Either SomeException a)+tryAll action = (Right <$> action) `catchAll` (return . Left)++-- | Flipped version of 'catchAll'+handleAll :: MonadBaseControl IO m => (SomeException -> m a) -> m a -> m a+handleAll = flip catchAll++throwLeftIO :: Exception e => Either e a -> IO a+throwLeftIO = throwLeftExceptionIO id++throwLeftExceptionIO :: Exception e => (a -> e) -> Either a b -> IO b+throwLeftExceptionIO mkEx e = either (throwIO . mkEx) pure e++-- | Detect 'SomeAsyncException' wrapped exceptions versus all others+isSyncException :: Exception e => e -> Bool+isSyncException e = case fromException (toException e) of+  Just (SomeAsyncException _) -> False+  Nothing -> True++-- | Detect 'SomeAsyncException' wrapped exceptions versus all others+isAsyncException :: Exception e => e -> Bool+isAsyncException = not . isSyncException++-- | A variant of 'bracket' where the release action also gets to see whether+-- the inner action succeeded or threw an exception.+tryBracket+  :: IO a                                   -- ^ run first+  -> (a -> Either SomeException b -> IO ()) -- ^ run finally+  -> (a -> IO b)                            -- ^ run in between+  -> IO b+tryBracket before after inner =+  mask $ \restore -> do+    a <- before+    r <- restore (inner a) `catch` \ex -> do+      after a (Left ex)+      throwIO ex+    _ <- after a (Right r)+    return r++-- | A variant of 'finally' where the final action also gets to see whether+-- the first action succeeded or threw an exception.+tryFinally+  :: IO a                              -- ^ run first+  -> (Either SomeException a -> IO ()) -- ^ run finally+  -> IO a+tryFinally inner after =+  mask $ \restore -> do+    r <- restore inner `catch` \ex -> do+      after (Left ex)+      throwIO ex+    _ <- after (Right r)+    return r++-- | Execute an action and invoke a function if it throws any exception. The+-- exception is then rethrown. Any exceptions from the function are ignored+-- (but logged).+onSomeException :: HasCallStack => IO a -> (SomeException -> IO ()) -> IO a+onSomeException io f = io `catch` \exc -> do+  withFrozenCallStack $ swallow $ f exc+  throwIO exc++-- | Execute an action and do something with its result even if it throws a+-- synchronous exception. Any exceptions from the function are ignored+-- (but logged).+afterwards :: HasCallStack => IO a -> (Either SomeException a -> IO ()) -> IO a+afterwards io f = do+  r <- tryAll io+  withFrozenCallStack $ swallow $ f r+  case r of+    Right result -> return result+    Left exc -> throwIO exc++-- | Execute an action and drop its result or any synchronous+-- exception it throws.  Exceptions are logged.+swallow :: HasCallStack => IO a -> IO ()+swallow io = void io `catchAll` \exc -> do+  withFrozenCallStack $ logError $ "swallowing exception: " ++ show exc++-- | Log and rethrow all synchronous exceptions arising from an+-- IO computation.+logExceptions :: HasCallStack => (String -> String) -> IO a -> IO a+logExceptions f io = withFrozenCallStack $+  io `onSomeException` (logError . f . show)
+ Util/Control/Exception/CallStack.hs view
@@ -0,0 +1,40 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++-- | Adds support to work with exceptions that pack a rendered call stack.+module Util.Control.Exception.CallStack (+  throwIO, throwSTM,+) where++import Control.Concurrent.STM (STM)+import qualified Control.Concurrent.STM as STM+import qualified Control.Exception as E+import Data.Text (Text, pack)+import GHC.Stack (+  HasCallStack,+  callStack,+  currentCallStack,+  prettyCallStack,+  renderStack,+  withFrozenCallStack,+ )++type CallStack = Text++throwIO :: (E.Exception e, HasCallStack) => (CallStack -> e) -> IO a+throwIO mkException = withFrozenCallStack $ do+  ccs <- currentCallStack+  let stack+        | null ccs = prettyCallStack callStack+        | otherwise = renderStack ccs+  E.throw $ mkException $ pack stack++throwSTM :: (E.Exception e, HasCallStack) => (CallStack -> e) -> STM a+throwSTM mkException = withFrozenCallStack $ do+  let stack = prettyCallStack callStack+  STM.throwSTM $ mkException $ pack stack
+ Util/Control/Monad.hs view
@@ -0,0 +1,33 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Control.Monad+  ( whenMonoid+  , whenDefault+  , whenMaybe+  , firstMLazy+  ) where++whenDefault :: Monad m => Bool -> a -> m a -> m a+whenDefault cond def monad =+  if cond then monad else return def++whenMaybe :: Monad m => Bool -> m (Maybe a) -> m (Maybe a)+whenMaybe b = whenDefault b Nothing++whenMonoid :: (Monad m, Monoid a) => Bool -> m a -> m a+whenMonoid b = whenDefault b mempty++-- | Performs the operations sequentially, and returns the first non-Nothing+-- value or throws the first exception immediately, whichever comes first.+--+-- Note: this serializes all the operations, only use this if you know+-- what you're doing.+--+firstMLazy :: (Foldable f, Monad m) => f (m (Maybe a)) -> m (Maybe a)+firstMLazy = foldr (\i j -> maybe j (pure . Just) =<< i) (pure Nothing)
+ Util/Defer.hs view
@@ -0,0 +1,45 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Defer (+  Defer, Embed(..), now, later, immediately, lift+) where++import Control.Applicative+import Control.Monad.Catch+import Control.Monad.STM+import Control.Monad.State.Strict++-- | Used to link an STM transaction and deferred IO actions to be run when that+-- transaction has been completed.+newtype Defer io stm a = Defer (StateT (io ()) stm a)+  deriving(+    Functor, Applicative, Alternative, Monad,+    MonadTrans, MonadThrow, MonadCatch)++-- | Run a given STM transaction inside a 'Defer'.+now :: Monad stm => stm a -> Defer io stm a+now = lift++-- | Used inside 'immediately' actions to append deferred IO actions to run+-- after the STM transaction has been completed.+later :: (Applicative io, Monad stm) => io () -> Defer io stm ()+later io = Defer $ modify' (*> io)++class Embed m1 m2 where+  embed :: m1 a -> m2 a++instance Embed STM IO where+  embed = atomically++-- | Run an STM transaction and then its deferred IO action.+immediately :: (Monad io, Monad stm, Embed stm io) => Defer io stm a -> io a+immediately (Defer action) = do+  (x,deferred) <- embed $ runStateT action $ return ()+  deferred+  return x
+ Util/Encoding.hs view
@@ -0,0 +1,28 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Encoding where++import GHC.IO.Encoding+  ( setForeignEncoding+  , setLocaleEncoding+  , utf8+  )++-- | Set the foreign/locale encoding used by GHC+-- If affects:+-- 1. Any handle in text mode that has not an explicit encoding set+--    including stdin, stdout and stderr+-- 2. Marshalling `String` to `CString` via functions in `Foreign.C.String`+setDefaultEncodingToUTF8 :: IO ()+setDefaultEncodingToUTF8 = do+  setForeignEncoding utf8+  setLocaleEncoding utf8++foreign export ccall "hs_setDefaultEncodingToUTF8"+  setDefaultEncodingToUTF8 :: IO ()
+ Util/Err.hs view
@@ -0,0 +1,24 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Err+  ( Err+  , errCtx+  , err+  ) where++-- | An error monad with multi-line nested error messages+type Err a = Either [String] a++err :: String -> Err a+err s = Left [s]++errCtx :: String -> Err a -> Err a+errCtx str e = case e of+  Left e' -> Left (str : map ("  " ++) e')+  Right a  -> Right a
+ Util/EventBase.hs view
@@ -0,0 +1,90 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.EventBase+  ( CppIOExecutor+  , EventBase(..)+  , EventBaseDataplane(..)+  , EventBaseProvider(..)+  , EventBaseDataplaneProvider(..)+  , withEventBaseDataplane+  , initExecutor+  , destroyExecutor+  ) where++import Control.Exception+import Foreign.Ptr+import Util.Executor++--+--  Makes an IOExecutor and makes it available in Haskell.+--++--+--  export+--++newtype EventBase = EventBase (Ptr CppEventBase)++class EventBaseProvider a where+  getEventBase :: a -> IO EventBase++newtype EventBaseDataplane = EventBaseDataplane (Ptr CppIOExecutor)++class EventBaseProvider a => EventBaseDataplaneProvider a where+  getEventBaseDataplane :: a -> IO EventBaseDataplane++instance EventBaseProvider EventBaseDataplane where+  getEventBase (EventBaseDataplane ptr) =+    EventBase <$> c_getIOExecutorEventBase ptr++instance EventBaseDataplaneProvider EventBaseDataplane where+  getEventBaseDataplane = return++instance ExecutorProvider EventBase where+  -- event bases are executors+  getExecutor (EventBase p) = Executor <$> c_castEventBaseToExecutor p++instance ExecutorProvider EventBaseDataplane where+  -- io executors are executors+  getExecutor (EventBaseDataplane p) = Executor <$> c_castIOExecutorToExecutor p++withEventBaseDataplane+    :: (EventBaseDataplane -> IO b)+    -> IO b+withEventBaseDataplane = bracket initExecutor destroyExecutor++initExecutor :: IO EventBaseDataplane+initExecutor = EventBaseDataplane <$> c_newExecutor++destroyExecutor :: EventBaseDataplane -> IO ()+destroyExecutor (EventBaseDataplane ptr) = c_destroyExecutor ptr++--+--  foreign+--++data CppEventBase+data CppIOExecutor++foreign import ccall unsafe "common_hs_eventbase_newExecutor"+  c_newExecutor :: IO (Ptr CppIOExecutor)++foreign import ccall unsafe "common_hs_eventbase_destroyExecutor"+  c_destroyExecutor :: Ptr CppIOExecutor -> IO ()++foreign import ccall unsafe "common_hs_eventbase_getIOExecutorEventBase"+  c_getIOExecutorEventBase :: Ptr CppIOExecutor -> IO (Ptr CppEventBase)++-- we cannot just use Haskell `castPtr` as there is virtual inheritance involved++foreign import ccall unsafe "common_hs_eventbase_castIOExecutorToExecutor"+  c_castIOExecutorToExecutor :: Ptr CppIOExecutor -> IO (Ptr CppFollyExecutor)++foreign import ccall unsafe "common_hs_eventbase_castEventBaseToExecutor"+  c_castEventBaseToExecutor :: Ptr CppEventBase -> IO (Ptr CppFollyExecutor)
+ Util/Executor.hs view
@@ -0,0 +1,57 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Executor+  ( CppFollyExecutor+  , Executor(..)+  , ExecutorKeepAlive(..)+  , ExecutorProvider(..)+  , getGlobalCPUExecutor+  , releaseGlobalCPUExecutor+  , withGlobalCPUExecutor+  ) where++import Foreign.Ptr+import Control.Exception (bracket)++-- CppExecutor is a folly::Executor*+data CppFollyExecutor+newtype Executor = Executor (Ptr CppFollyExecutor)++data CppFollyExecutorKeepAlive+newtype ExecutorKeepAlive = ExecutorKeepAlive (Ptr CppFollyExecutorKeepAlive)++class ExecutorProvider a where+  getExecutor :: a -> IO Executor++instance ExecutorProvider Executor where+  getExecutor = return++instance ExecutorProvider ExecutorKeepAlive where+  getExecutor (ExecutorKeepAlive p) = Executor <$> c_getExecutorFromKeepAlive p++getGlobalCPUExecutor :: IO ExecutorKeepAlive+getGlobalCPUExecutor = ExecutorKeepAlive <$> c_getGlobalCPUExecutor++releaseGlobalCPUExecutor :: ExecutorKeepAlive -> IO ()+releaseGlobalCPUExecutor (ExecutorKeepAlive p) = c_releaseGlobalCPUExecutor p++withGlobalCPUExecutor+    :: (ExecutorKeepAlive -> IO b)+    -> IO b+withGlobalCPUExecutor = bracket getGlobalCPUExecutor releaseGlobalCPUExecutor++foreign import ccall unsafe "common_hs_getGlobalCPUExecutor"+  c_getGlobalCPUExecutor :: IO (Ptr CppFollyExecutorKeepAlive)++foreign import ccall unsafe "common_hs_releaseGlobalCPUExecutor"+  c_releaseGlobalCPUExecutor :: Ptr CppFollyExecutorKeepAlive -> IO ()++foreign import ccall unsafe "common_hs_getExecutorFromKeepAlive"+  c_getExecutorFromKeepAlive+    :: Ptr CppFollyExecutorKeepAlive -> IO (Ptr CppFollyExecutor)
+ Util/FFI.hs view
@@ -0,0 +1,156 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-star-is-type #-}+module Util.FFI (+  FFIError, ffiErrorMessage, call,+  List(..), FFIFun(..), Tuple(..), invoke,++  unsafeWithForeignPtr,+) where++import Foreign hiding (with, withMany)+import Foreign.C+#if __GLASGOW_HASKELL__ >= 902+import GHC.ForeignPtr+#endif+import System.IO.Unsafe (unsafePerformIO)+import Control.Exception+import Control.Monad++#if __GLASGOW_HASKELL__ < 902+unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b+unsafeWithForeignPtr = withForeignPtr+#endif++foreign import ccall unsafe "&hs_ffi_free_error" hs_ffi_free_error+  :: FunPtr (CString -> IO ())++newtype FFIError = FFIError (ForeignPtr CChar)++ffiErrorMessage :: FFIError -> String+ffiErrorMessage (FFIError fp) =+  unsafePerformIO $ unsafeWithForeignPtr fp peekCString++instance Show FFIError where+  show = ffiErrorMessage++instance Exception FFIError++-- | Call an FFI function that returns 'nullPtr' if it succeeds, or a+-- 'CString' containing the error message if it fails.  On failure the+-- error is thrown as an 'FFIError' exception.+{-# INLINE call #-}+call :: IO CString -> IO ()+call f = do+  p <- f+  when (p /= nullPtr) $ callError p++callError :: CString -> IO ()+callError p = do+  fp <- newForeignPtr hs_ffi_free_error p+  throwIO $ FFIError fp++infixr 5 :>++data List xs where+  Nil :: List '[]+  (:>) :: x -> List xs -> List (x ': xs)++class Tuple xs where+  type Tup xs+  tuple :: List xs -> Tup xs++instance Tuple '[] where+  type Tup '[] = ()+  tuple Nil = ()++instance Tuple '[a] where+  type Tup '[a] = a+  tuple (a :> _) = a++instance Tuple [a,b] where+  type Tup [a,b] = (a,b)+  tuple (a :> b :> _) = (a,b)++instance Tuple [a,b,c] where+  type Tup [a,b,c] = (a,b,c)+  tuple (a :> b :> c :> _) = (a,b,c)++instance Tuple [a,b,c,d] where+  type Tup [a,b,c,d] = (a,b,c,d)+  tuple (a :> b :> c :> d :> _) = (a,b,c,d)++instance Tuple [a,b,c,d,e] where+  type Tup [a,b,c,d,e] = (a,b,c,d,e)+  tuple (a :> b :> c :> d :> e :> _) = (a,b,c,d,e)++instance Tuple [a,b,c,d,e,f] where+  type Tup [a,b,c,d,e,f] = (a,b,c,d,e,f)+  tuple (a :> b :> c :> d :> e :> f :> _) = (a,b,c,d,e,f)++instance Tuple [a,b,c,d,e,f,g] where+  type Tup [a,b,c,d,e,f,g] = (a,b,c,d,e,f,g)+  tuple (a :> b :> c :> d :> e :> f :> g :> _) = (a,b,c,d,e,f,g)++instance Tuple [a,b,c,d,e,f,g,h] where+  type Tup [a,b,c,d,e,f,g,h] = (a,b,c,d,e,f,g,h)+  tuple (a :> b :> c :> d :> e :> f :> g :> h :> _) = (a,b,c,d,e,f,g,h)++instance Tuple [a,b,c,d,e,f,g,h,i] where+  type Tup [a,b,c,d,e,f,g,h,i] = (a,b,c,d,e,f,g,h,i)+  tuple (a :> b :> c :> d :> e :> f :> g :> h :> i :> _) = (a,b,c,d,e,f,g,h,i)++class FFIFun f where+  type Res f :: [*]+  invoke' :: f -> IO (List (Res f))++instance FFIFun (IO CString) where+  type Res (IO CString) = '[]+  invoke' f = do+    call f+    return Nil++instance FFIFun (IO ()) where+  type Res (IO ()) = '[]+  invoke' f = do+    f+    return Nil++-- | For output parameter 'Ptr a' this will 'alloca' memory (unitialized)+-- and then proceed to the next parameter.  On returning this prepends+-- the result into x.  This is only safe if the invoked function+-- always fills in this output parameter pointer before returning.+instance (Storable a, FFIFun f) => FFIFun (Ptr a -> f) where+  type Res (Ptr a -> f) = a ': Res f+  invoke' f = alloca $ \p -> do+    xs <- invoke' (f p)+    x <- peek p+    return $ x :> xs++-- | Call an FFI function with automatic handling of return values and+-- errors.+--+-- For example, if we have a function with one input and two outputs,+-- optionally returning an error as a `CString`:+--+-- > foreign import ccall unsafe json_encode+-- >   :: Ptr Dyn -> Ptr (Ptr Word8) -> Ptr CSize -> IO CString+--+-- Then we can call it like this:+--+-- >   (bytes, size) <- invoke $ json_encode dyn+--+-- where @bytes :: Ptr Word8@ and @size :: CSize@.+--+-- Note: this is only safe if the invoked function always fills in+-- output parameter pointers before returning.+invoke :: (FFIFun f, Tuple (Res f)) => f -> IO (Tup (Res f))+invoke = fmap tuple . invoke'
+ Util/Fd.hs view
@@ -0,0 +1,46 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Fd+  ( withFdEventNotification+  ) where++import Control.Exception+import Control.Monad+import GHC.Event hiding (closeFd)+import Foreign.C+import System.Posix.IO+import System.Posix.Types++-- | Uses a file descriptor and GHC's event manager to run a callback+-- once the file descriptor is written to. Is less expensive than a new FFI+-- call from C++ back into Haskell.+withFdEventNotification+  :: Exception e+  => e -- ^ Exception to throw when unable to get the event manager+  -> IO () -- ^ The callback to run on fd write+  -> Lifetime -- ^ OneShot or MultiShot+  -> (Fd -> IO a) -- ^ Action to run with the file descriptor to write to+  -> IO a+withFdEventNotification err callback lifetime action = do+  evm <- maybe (throw err) return =<< getSystemEventManager+  withEventFd $ \fd ->+    bracket (registerFd evm cb fd evtRead lifetime) (unregisterFd evm) $+      const $ action fd+  where+    cb _ _ = callback++withEventFd :: (Fd -> IO a) -> IO a+withEventFd = bracket+  (do fd <- c_eventfd 0 0+      when (fd == -1) $ throwErrno "eventFd"+      return $ Fd fd)+  closeFd++foreign import ccall unsafe "eventfd"+  c_eventfd :: CInt -> CInt -> IO CInt
+ Util/FilePath.hs view
@@ -0,0 +1,68 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.FilePath+  ( DirEnv(..)+  , getDirEnv+  , absolutise+  , absolutiseWith+  , mnameToPath+  , pathToMName+  ) where++import Data.Char (isAsciiUpper)+import Data.Text (Text)+import Data.Text as Text (pack, unpack)++import System.Directory+import System.FilePath++data DirEnv = DirEnv+  { homeDir :: FilePath+  , currentDir :: FilePath+  }++getDirEnv :: IO DirEnv+getDirEnv = DirEnv <$> getHomeDirectory <*> getCurrentDirectory++-- | Makes a path absolute, handling home directories+absolutiseWith :: DirEnv -> FilePath -> FilePath+absolutiseWith DirEnv{..} "~" = homeDir+absolutiseWith DirEnv{..} ('~':'/':p) = normalise $ homeDir </> p+absolutiseWith DirEnv{..} p | isRelative p = normalise $ currentDir </> p+absolutiseWith _ p = p++-- | Get the absolute FilePath based on the directory env+--+-- >>> absolutise "~/si_sigma/A.hs"+-- "{HOME_DIR}/si_sigma/A.hs"+-- >>> absolutise "sigma/repo/Foo/Bar/Baz.hs"+-- "{CURRENT_DIR}/sigma/repo/Foo/Bar/Baz.hs"+absolutise :: FilePath -> IO FilePath+absolutise p = absolutiseWith <$> getDirEnv <*> pure p++-- | Given a FilePath to a module, returns the expected module name+--+-- >>> pathToMName "sigma/repo/Foo/Bar/Baz.hs"+-- "Foo.Bar.Baz"+pathToMName :: FilePath -> Text+pathToMName = Text.pack . map convSeparator . getModulePath . dropExtension+  where+    convSeparator c = if isPathSeparator c then '.' else c+    getModulePath = joinPath . filterModulePaths . splitPath+    filterModulePaths = reverse . takeWhile isModulePath . reverse+    isModulePath (c:_) = isAsciiUpper c+    isModulePath _ = False++-- | Given a module name, returns the FilePath+--+-- >>> mnameToPath "Foo.Bar.Baz"+-- "Foo/Bar/Baz.hs"+mnameToPath :: Text -> FilePath+mnameToPath =+  (<> ".hs") . map (\c -> if c == '.' then pathSeparator else c) . Text.unpack
+ Util/Function.hs view
@@ -0,0 +1,15 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Function+  ( compose+  ) where++-- | Composes a list of endofunctions.+compose :: [a -> a] -> a -> a+compose = foldr (.) id
+ Util/Graph.hs view
@@ -0,0 +1,42 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Graph+  ( postorder+  ) where++import Data.Hashable+import qualified Data.HashSet as HashSet+import qualified Data.HashMap.Strict as HashMap++-- | Post-order traversal of a graph: guarantees that the dependents+-- of a node occur before it in the result list, while as far as+-- possible retaining the original order of the nodes.+postorder+  :: (Hashable vertex, Eq vertex)+  => [node]+    -- ^ Nodes in the order of traversal+  -> (node -> vertex)+    -- ^ Extract a hashable vertex from the node+  -> (node -> [vertex])+    -- ^ Out-edges from a node. Vertices that aren't in the set of+    -- nodes are ignored.+  -> [node]+    -- ^ Result of post-order traversal+postorder nodes vert out = go HashSet.empty nodes (\_ -> [])+  where+  m = HashMap.fromList [ (vert n, n) | n <- nodes ]++  go seen [] cont = cont seen+  go seen (n : nodes) cont+    | v `HashSet.member` seen = go seen nodes cont+    | otherwise = go (HashSet.insert v seen) deps+       (\seen -> n : go seen nodes cont)+    where+      v = vert n+      deps = [ n | v <- out n, Just n <- [HashMap.lookup v m] ]
+ Util/HSE.hs view
@@ -0,0 +1,24 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE CPP #-}++module Util.HSE+  (+    classA+  ) where++import Language.Haskell.Exts.Syntax hiding (Type)+import qualified Language.Haskell.Exts.Syntax as HS++classA :: l -> QName l -> [HS.Type l] -> Asst l+#if MIN_VERSION_haskell_src_exts(1,22,0)+classA l conName args = TypeA l (foldl (TyApp l) (TyCon l conName) args)+#else+classA = ClassA+#endif
+ Util/HUnit.hs view
@@ -0,0 +1,107 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.HUnit+  ( absError+  , assertAbsError+  , assertElem+  , assertSubsetOf+  , assertNotElem+  , assertPermutationOf+  , assertThrow+  ) where++import Control.Exception+import Data.Either (isLeft)+import Data.Foldable (toList)+import Data.List+import Test.HUnit+++-- | The absolute error between an expected and actual value.+absError :: (Fractional a) => a -> a -> a+absError expected actual = abs (expected - actual)++-- | Asserts that the absolute error of a value is within a given+-- range. If you want the range to be in the realm of machine epsilon,+-- use @Data.AEq@ instead.+assertAbsError+  :: (Fractional a, Ord a, Show a)+  => String+  -- ^ Error message.+  -> a+  -- ^ Expected value.+  -> a+  -- ^ Error range (e.g., @1e-3@).+  -> a+  -- ^ Actual value.+  -> Assertion+assertAbsError message expected epsilon actual+  = flip assertBool (absError expected actual <= epsilon) $ concat+  [ message+  , " (expected "+  , show expected+  , "+/-"+  , show epsilon+  , " but got "+  , show actual+  , ")"+  ]++assertPermutationOf+  :: (Ord a, Show a)+  => String -> [a] -> [a] -> Assertion+assertPermutationOf m as bs = assertEqual m (sort as) (sort bs)++assertElem :: (Eq a, Show a, Foldable t) => String -> a -> t a -> Assertion+assertElem message expected actual =+  flip assertBool (expected `elem` actual) $ concat+    [ message+    , " (expected "+    , show expected+    , " to occur in "+    , show $ toList actual+    , ")"+    ]++assertSubsetOf+  :: (Eq a, Show a, Foldable t, Foldable f)+  => String+  -> f a+  -> t a+  -> Assertion+assertSubsetOf message expected actual =+  flip assertBool (all (`elem` actual) expected) $ concat+    [ message+    , " (expected all of"+    , show $ toList expected+    , " to occur in "+    , show $ toList actual+    , ")"+    ]++assertNotElem :: (Eq a, Show a, Foldable t) => String -> a -> t a -> Assertion+assertNotElem message expected actual =+  flip assertBool (not $ expected `elem` actual) $ concat+    [ message+    , " (expected "+    , show expected+    , " to not occur in "+    , show $ toList actual+    , ")"+    ]++assertThrow :: (Show a) => String -> IO a -> Assertion+assertThrow message test = do+  (actual :: Either SomeException a) <- try test+  flip assertBool (isLeft actual) $ concat+    [ message+    , " (expected: exception thrown; but got: "+    , show actual+    , ")"+    ]
+ Util/HashMap/Strict.hs view
@@ -0,0 +1,21 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.HashMap.Strict+  ( mapKeys+  ) where++import Control.Arrow (first)+import Data.Hashable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap++-- | Transform a HashMap by applying a function to every key.+mapKeys :: (Eq b, Hashable b) => (a -> b) -> HashMap a v -> HashMap b v+mapKeys mapper =+  HashMap.fromList . map (first mapper) . HashMap.toList
+ Util/IO.hs view
@@ -0,0 +1,438 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.IO+  ( atomicIO+  , die+  , readFileUTF8+  , writeFileUTF8+  , writeFileAtomicUTF8+  , readJSON+  , eitherReadJSON+  , writeJSON+  , writeJSON'+  , removeIfExists+  , readFileIfExists+  , writeFileIfChanged+  , writeFileAtomically+  , writeTextIfChanged+  , loudlyWriteTextIfChanged+  , writeTextIfChangedWith+  , writeUtf8StringIfChanged+  , loudlyWriteUtf8StringIfChanged+  , writeUtf8StringIfChangedWith+  , Verbosity(..)+  , writeFileUTF8Text+  , readFileUTF8Text+  , getDevserverUser+  , getDevserverHostInfo+  , getHostInfo+  , getHostname+  , getUserForProcess+  , getGroupForProcess+  , getUsername+  , getUserUnixname+  , HostInfo(..)+  , copyDirectoryContents+  , copyDirectoryContents_+  , listDirectoryRecursive+  , saveStdout+  , saveStderr+  , slowIO+  , isModifiedAfter+  , safeRemovePathForcibly+  , withLazy+  ) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Exception as Exception+import Control.Monad+import Control.Monad.Extra+import Data.Aeson+import Data.Aeson.Encode.Pretty+import Data.Foldable+import Data.List+import Data.List.Split+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as TextIO+import GHC.IO.Handle+import System.Directory+import System.Exit hiding (die)+import System.FilePath+import System.IO+import System.IO.Error+import System.IO.Unsafe+import System.Posix.User+import System.Process+import System.Environment+import Text.Printf+import Util.String (strip)+import qualified Data.ByteString.Lazy as B++-- | Performs some IO atomically. This is presumed to be only used+-- to avoid output interleaving where verbose information is printed+-- concurrently.+atomicIO :: IO a -> IO a+atomicIO = withMVar atomicIOLock . const++{-# NOINLINE atomicIOLock #-}+atomicIOLock :: MVar ()+atomicIOLock = unsafePerformIO $ newMVar ()++-- | Exit immediately with 'exitCode', showing a message on 'stderr'.+die :: Int -> String -> IO a+die exitCode msg =+  hPutStrLn stderr msg >> exitWith (ExitFailure exitCode)++-- | Compare a file's content against some benchmark content to see+-- whether it's changed. You really want to pass in some kind of lazy+-- read function here so that (in-)equality can be determined as soon+-- as possible during the file read. Note that if the file doesn't+-- exist, then we return True, that is, we state that the file has+-- changed.+hasFileContentChanged ::+  (Eq a) => (FilePath -> IO a) -> FilePath -> a -> IO Bool+hasFileContentChanged read filePath benchmarkContent =+  catchIOError+    (liftM (/= benchmarkContent) $ read filePath)+    (\_ -> return True)++-- | Writes a file only if it differs from the content that would be+-- written.+writeFileIfChanged :: (Eq a) =>+  (FilePath -> IO a) -> (Handle -> a -> IO ()) -> FilePath -> a -> IO ()+writeFileIfChanged read hWrite targetPath content = do+  different <- hasFileContentChanged read targetPath content+  when different $ writeFileAtomically hWrite targetPath content++-- | Write a file "atomically" by writing it fully to a temp+-- directory, then copying it to its final location.+writeFileAtomically :: (Handle -> a -> IO ()) -> FilePath -> a -> IO ()+writeFileAtomically hWrite targetPath content =+    Exception.bracketOnError mkTempFile rmTempFile commit+  where+    (targetDir, targetFile) = splitFileName targetPath+    mkTempFile = openTempFile targetDir (targetFile <.> "tmp")+    rmTempFile (tmpPath, handle) = hClose handle >> removeFile tmpPath+    commit (tmpPath, handle) = do+      hWrite handle content+      hClose handle+      renameFile tmpPath targetPath++-- | Remove file if it exists. Returns True if the file existed.+removeIfExists :: FilePath -> IO Bool+removeIfExists filePath =+  (removeFile filePath >> return True) `catch` \e ->+    if isDoesNotExistError e+      then return False+      else throwIO e++readFileIfExists :: FilePath -> IO (Maybe String)+readFileIfExists filePath =+  (Just <$> readFile filePath) `catch` \e ->+    if isDoesNotExistError e+      then return Nothing+      else throwIO e++-- | Read a FromJSON datatype from a file containing a JSON string.+readJSON :: FromJSON a => FilePath -> IO a+readJSON f = do+  json <- B.readFile f+  case eitherDecode json of+    Left err -> error $ printf "Failed parsing JSON file %s: %s\n" f err+    Right v  -> return v++eitherReadJSON :: FromJSON a => FilePath -> IO (Either String a)+eitherReadJSON f = (eitherDecode <$> B.readFile f)+  `catch` (\(e :: Exception.IOException) -> return $ Left (show e))++-- |  Write a ToJSON datatype to a file as pretty-printed JSON.+writeJSON :: ToJSON a => FilePath -> a -> IO ()+writeJSON path = B.writeFile path . encodePretty++-- | Write a ToJSON datatype to a file as pretty-printed JSON.+-- Adds a newline at the end of the file+writeJSON' :: ToJSON a => Config -> FilePath -> a -> IO ()+writeJSON' config path obj = B.writeFile path (encodePretty' config obj <> "\n")++-- | Read a UTF-8 encoded file.  Like 'readFile' but forces the+-- encoding to UTF-8.+readFileUTF8 :: FilePath -> IO String+readFileUTF8 path = do+  h <- openFile path ReadMode+  hSetEncoding h utf8+  hGetContents h++-- | Write a UTF-8 encoded file.  Like 'writeFile' but forces the+-- encoding to UTF-8.+writeFileUTF8 :: Handle -> String -> IO ()+writeFileUTF8 h str = do+    hSetEncoding h utf8+    hPutStr h str++-- | Write a UTF-8 encoded file atomically.  Writes to a temporary file+-- first, and then atomically moves the temporary file to the destination+-- if successful.+--+-- Adapted from Distribution.Simple.Utils.writeFileAtomic in Cabal.+writeFileAtomicUTF8 :: FilePath -> String -> IO ()+writeFileAtomicUTF8 targetPath content = do+  let (targetDir, targetFile) = splitFileName targetPath+  Exception.bracketOnError+    (do+      createDirectoryIfMissing True targetDir+      openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")+    (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)+    (\(tmpPath, handle) -> do+        hSetEncoding handle utf8+        hPutStr handle content+        hClose handle+        renameFile tmpPath targetPath)++-- | Write a UTF-8 encoded file from text, only if it differs from the content+-- that would be written. If the output directory will be created if it does+-- not exist.+writeTextIfChanged :: FilePath -> Text -> IO ()+writeTextIfChanged path text = do+  createDirectoryIfMissing True $ takeDirectory path+  writeFileIfChanged readFileUTF8Text writeFileUTF8Text path text++-- Like Util.IO.writeTextIfChanged, but announce upon success.+loudlyWriteTextIfChanged :: FilePath -> Text -> IO ()+loudlyWriteTextIfChanged = writeTextIfChangedWith Loud putStrLn++data Verbosity = Loud | Quiet++writeTextIfChangedWith+  :: Verbosity+  -> (String -> IO ())+  -> FilePath+  -> Text+  -> IO ()+writeTextIfChangedWith verbosity f path text = do+  createDirectoryIfMissing True $ takeDirectory path+  writeFileIfChanged readFileUTF8Text writeFileUTF8Text_ path text+  where+  writeFileUTF8Text_ h txt = do+    writeFileUTF8Text h txt+    case verbosity of+      Loud -> atomicIO $ f ("Written " ++ path)+      Quiet -> return ()++-- | Write a UTF-8 encoded file from text.  Like 'writeFile' but forces the+-- encoding to UTF-8.+writeFileUTF8Text :: Handle -> Text -> IO ()+writeFileUTF8Text h text = do+  hSetEncoding h utf8+  TextIO.hPutStr h text++-- | Read a UTF-8 encoded file as text.+readFileUTF8Text :: FilePath -> IO Text+readFileUTF8Text path = do+  h <- openFile path ReadMode+  hSetEncoding h utf8+  TextIO.hGetContents h++-- Like Util.IO.writeTextIfChanged, but works for String+writeUtf8StringIfChanged :: FilePath -> String -> IO ()+writeUtf8StringIfChanged path content = do+  createDirectoryIfMissing True $ takeDirectory path+  writeFileIfChanged readFileUTF8 writeFileUTF8 path content++-- Like Util.IO.loudlyWriteTextIfChanged, but works for String.+loudlyWriteUtf8StringIfChanged :: FilePath -> String -> IO ()+loudlyWriteUtf8StringIfChanged = writeUtf8StringIfChangedWith Loud putStrLn++-- Like Util.IO.writeTextIfChangedWith, but works for String+writeUtf8StringIfChangedWith+  :: Verbosity+  -> (String -> IO ())+  -> FilePath+  -> String+  -> IO ()+writeUtf8StringIfChangedWith verbosity f path content = do+  createDirectoryIfMissing True $ takeDirectory path+  writeFileIfChanged readFileUTF8 writeFileUTF8_ path content+  where+  writeFileUTF8_ h txt = do+    writeFileUTF8 h txt+    case verbosity of+      Loud -> atomicIO $ f ("Written " ++ path)+      Quiet -> return ()++getUserForProcess :: IO String+getUserForProcess = fmap userName $ getUserEntryForID =<< getRealUserID++getGroupForProcess :: IO String+getGroupForProcess = fmap groupName $ getGroupEntryForID =<< getRealGroupID++data HostInfo = HostInfo+  { hostname :: Text+  , username :: Text+  }++getHostInfo :: IO HostInfo+getHostInfo = do+  user <- Text.pack <$> getUsername+  host <- Text.pack <$> getHostname+  return $ HostInfo host user++getDevserverHostInfo :: IO HostInfo+getDevserverHostInfo = do+  user <- Text.pack <$> getDevserverUser+  host <- Text.pack <$> getHostname+  return $ HostInfo host user++-- | Equivalent of get_devserver_username in www (see+-- https://fburl.com/codex/05mqipn2).+getDevserverUser :: IO String+getDevserverUser = getUserForProcess++-- | Get username using 'id' command line tool+getUsername :: IO String+getUsername = init <$> readProcess "id" ["-un"] ""++-- | Get hostname using 'hostname' command line tool+getHostname :: IO String+getHostname = strip <$> readProcess "hostname" [] []++-- Try to get a meaninful user unix name. This will not realize that the user+-- was changed to a non-root account like mysql.+getUserUnixname :: IO String+getUserUnixname = do+  user <- getUserForProcess+  fromMaybe user <$> asum+    [ return $ helpful $ Just user+    , helpful <$> getTupperwareUser+    , helpful <$> getDevserverOwner+    ]+  where+    unhelpfulNames = ["root", "twsvcscm", "svcscm", "apache"]++    helpful (Just name) | name `elem` unhelpfulNames = Nothing+    helpful mname = mname++    getTupperwareUser = lookupEnv "TW_JOB_USER"++getDevserverOwner :: IO (Maybe String)+getDevserverOwner = do+  res <- Exception.try $ readFile "/etc/devserver.owners"+    :: IO (Either Exception.SomeException String)+  return $ case lines <$> res of+    Right (name:_) -> Just name+    _ -> Nothing++redirectHandle :: Handle -> FilePath -> IO () -> IO ()+redirectHandle handle file io =+  withFile file WriteMode $ \fh -> do+  bracket (hDuplicate handle) (`hDuplicateTo` handle) $ \_ -> do+    hDuplicateTo fh handle+    io++-- | Run an IO action saving the stderr to a file+saveStderr :: FilePath -> IO () -> IO ()+saveStderr = redirectHandle stderr++-- | Run an IO action saving the stdout to a file+saveStdout :: FilePath -> IO () -> IO ()+saveStdout = redirectHandle stdout++-- | Copy all the contents of one directory to another directory+-- and return all the resulting paths.+-- This will create the target directory if it does not exist.++-- | DISCLAIMER: This is not an atomic operation.+copyDirectoryContents :: FilePath -> FilePath -> IO [FilePath]+copyDirectoryContents dirfrom dirto = do+  paths <- listDirectoryRecursive dirfrom+  forM paths $ \path -> do+      let relfile = makeRelative dirfrom path+      let frompath = dirfrom </> relfile+      let topath = dirto </> relfile+      createDirectoryIfMissing True $ takeDirectory topath+      copyFile frompath topath+      return topath++copyDirectoryContents_ :: FilePath -> FilePath -> IO ()+copyDirectoryContents_ dirfrom dirto+  = void $ copyDirectoryContents dirfrom dirto++listDirectoryRecursive+    :: FilePath+    -> IO [FilePath]+listDirectoryRecursive dir = do+    fs <- listDirectory dir+    (concat <$>) $ forM fs $ \file -> do+        let f = dir </> file+        isFile <- doesFileExist f+        if isFile+        then return [f]+        else do+            isDir <- doesDirectoryExist f+            if isDir+            then listDirectoryRecursive f+            else return []+++-- | Perform IO in batches with delays between them. Useful to avoid+-- filling up fixed size queues.+slowIO+  :: ([a] -> IO ())                     -- ^ operation to apply to each batch+  -> [a]                                -- ^ all arguments+  -> Int                                -- ^ maximum batch size+  -> Int                                -- ^ delay, in milliseconds+  -> IO ()+slowIO f args batchSize delay =+  sequence_+    $ intersperse (threadDelay (delay*1000))+    $ map f+    $ chunksOf batchSize args++isModifiedAfter :: FilePath -> FilePath -> IO Bool+isModifiedAfter fp1 fp2 = ifM (doesFileExist fp1 &&^ doesFileExist fp2)+  (do+    time <- getModificationTime fp1+    time' <- getModificationTime fp2+    return $ time > time')+  (return False)++-- | System.Posix.removeLink calls @unlink()@ with an unsafe FFI call,+-- which can cause long stalls in some cases. This affects things+-- defined in terms of it, including 'System.Directory.removeFile',+-- and 'System.Directory.removePathForcibly' to name a couple.+--+-- This function is a replacement for 'removePathForcibly' that forks+-- an external 'rm' instead.+safeRemovePathForcibly :: FilePath -> IO ()+safeRemovePathForcibly path = callProcess "rm" [ "-rf", path ]++-- | Turn a with-style resource scoping function into one that+-- executes lazily. The @with@ is performed the first time the+-- supplied getter is invoked, and is released when @withLazy@+-- returns.+withLazy+  :: (forall b . (a -> IO b) -> IO b)+    -- ^ with-style function to allocate a scoped resource of type @a@+  -> (IO a -> IO c)+    -- ^ provides a lazy getter for the resource @a@+  -> IO c+withLazy wit fn = do+  barrier <- newEmptyMVar+  result <- newEmptyMVar+  done <- newEmptyMVar+  let+    get = do _ <- tryPutMVar barrier (); readMVar result+    go = do+      takeMVar barrier+      wit $ \a -> do+        putMVar result a+        takeMVar done+  snd <$> concurrently go (fn get `finally` putMVar done ())
+ Util/IOBuf.hsc view
@@ -0,0 +1,101 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.IOBuf+  ( unsafeWithIOBuf+  , IOBuf+  , toLazy+  ) where++import Control.Exception (mask_)+import Data.ByteString.Internal+import Data.ByteString.Unsafe+import Data.Word+import Foreign.C+import Foreign.ForeignPtr+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.Storable+import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString as Strict++#include <cpp/IOBuf.h>++-- | This is the representation of a C++ HS_IOBuf. It has no representation in+-- Haskell therefore we use an uninhabited type+data IOBuf++-- We need a Storable instance in order to alloca an HS_IOBuf from haskell+instance Storable IOBuf where+  sizeOf _ = (#size HS_IOBuf)+  alignment _ = alignment (undefined :: Ptr ())+  -- IOBuf is an uninhabited type, so peek and poke are not implemented+  peek = error "peek: unimplemented"+  poke = error "poke: unimplemented"++-- | Marshal a lazy ByteString to a C++ HS_IOBuf and call a function on the+-- result. This is unsafe because it uses the underlying bytestring buffers of+-- the Haskell ByteString in C++. If this gets garbage collected while it is+-- still being used in C++, then the program will crash.+unsafeWithIOBuf :: Lazy.ByteString -> (Ptr IOBuf -> IO a) -> IO a+unsafeWithIOBuf bs f =+  withChain (Lazy.toChunks bs) $ \str_arr len_arr len ->+  alloca $ \hs_iobuf -> do+    (#poke HS_IOBuf, str_arr) hs_iobuf str_arr+    (#poke HS_IOBuf, len_arr) hs_iobuf len_arr+    (#poke HS_IOBuf, len) hs_iobuf len+    f hs_iobuf++withChain+  :: [ByteString]+  -> (Ptr CString -> Ptr CSize -> CSize -> IO a)+  -> IO a+withChain chunks f = withMany unsafeUseAsCStringLen chunks $ \cstrs ->+  let+    (strs, lens) = unzip cstrs+  in+    withArrayLen strs $ \len strings ->+    withArray (map fromIntegral lens) $ \lengths ->+    f strings lengths (fromIntegral len)++data CIOBufData++-- The ForeignPtr points to the data buffer, not the IOBuf, but+-- the finalizer calls the destructor on the IOBuf*.+-- This function takes ownership of Ptr IOBuf.+toByteString :: Ptr IOBuf -> Int -> Ptr Word8 -> IO Strict.ByteString+toByteString p p_len p_buf = mask_ $ do+  fp <- newForeignPtrEnv c_destroy p p_buf+  return $ fromForeignPtr fp 0 p_len++-- | A mock fmap over the IOBuf chain to create strict ByteStrings.+bufToChunks+  :: Ptr IOBuf+  -> IO [Strict.ByteString]+bufToChunks ptr+  | ptr == nullPtr = pure []+  | otherwise = allocaBytes #{size IOBufData} $ \p_data -> do+      c_get_data ptr p_data+      p_len <- #{peek IOBufData, length_} p_data+      p_buf <- #{peek IOBufData, data_buf_} p_data+      p_next <- #{peek IOBufData, next_} p_data+      (:) <$> toByteString ptr p_len p_buf+          <*> bufToChunks p_next++-- | Marshall a folly::IOBuf to a lazy ByteString. Could also fold and append+-- to a lazy ByteString instead of using fromChunks.+toLazy :: Ptr IOBuf -> IO Lazy.ByteString+toLazy p = Lazy.fromChunks <$>+  (mask_ $ bufToChunks p)++foreign import ccall unsafe "get_iobuf_data" c_get_data+  :: Ptr IOBuf -> Ptr CIOBufData -> IO ()+foreign import ccall unsafe "&destroy_iobuf" c_destroy+  :: FinalizerEnvPtr IOBuf Word8
+ Util/JSON/Pretty.hs view
@@ -0,0 +1,66 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# OPTIONS -Wno-orphans #-}++-- | Display JSON values using pretty printing combinators.+--+-- Adapted from Text.Pretty.JSON in the json package, which is+--   Copyright (c) Galois, Inc. 2007+--+-- Why would you use this instead of Aeson + aeson-pretty?+--   1. You want to retain the ordering of fields in JSON objects. Aeson+--      doesn't do this.+--   2. The pretty-printer here produces more compact output than aeson-pretty.++module Util.JSON.Pretty+  ( -- instance Pretty JSValue+  ) where++import Data.Ratio+import Data.Char+import Numeric+import Text.JSON++import Compat.Prettyprinter++instance Pretty JSValue where+  pretty v = case v of+    JSNull -> "null"+    JSBool True -> "true"+    JSBool False -> "false"+    JSRational asf x -> pp_number asf x+    JSString x -> pp_string (fromJSString x)+    JSArray vs -> pp_array vs+    JSObject xs -> pp_object (fromJSObject xs)++pp_number :: Bool -> Rational -> Doc a+pp_number _ x | denominator x == 1 = pretty (numerator x)+pp_number True x = pretty (fromRational x :: Float)+pp_number _ x = pretty (fromRational x :: Double)++pp_array :: [JSValue] -> Doc a+pp_array xs = sep [nest 2 (vsep ("[" : punctuate comma (map pretty xs))), "]"]++pp_object :: [(String,JSValue)] -> Doc a+pp_object xs =+  sep [nest 2 (vsep ("{" : punctuate comma (map pp_field xs))), "}"]+  where pp_field (k,v) = pp_string k <> colon <+> pretty v++pp_string :: String -> Doc a+pp_string x = dquotes $ hcat $ map pp_char x+  where pp_char '\\'            = "\\\\"+        pp_char '"'             = "\\\""+        pp_char c | isControl c = uni_esc c+        pp_char c               = pretty [c]++        uni_esc c = "\\u" <> pretty (pad 4 (showHex (fromEnum c) ""))++        pad n cs  | len < n   = replicate (n-len) '0' ++ cs+                  | otherwise = cs+          where len = length cs
+ Util/Lens.hs view
@@ -0,0 +1,34 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Lens+  ( lowerCamelCaseLensRules+  , makeLowerCCLenses+  ) where++import Control.Lens+import Data.Char+import Data.List.Split+import Language.Haskell.TH+++-- | Rules for makin lower camel case lenses+-- lf_name becomes lfName+lowerCamelCaseLensRules :: LensRules+lowerCamelCaseLensRules = lensRules & lensField .~ lowerCamelCaseNamer+  where+  lowerCamelCase = concat . (_tail %~ map (_head %~ toUpper)) . splitOn "_"+  lowerCamelCaseNamer _ _ n =+    case nameBase n of+      ('_':_) -> []+      field -> [ TopName $ mkName $ lowerCamelCase field ]++-- | Make lower camel case lenses+-- lf_name becomes lfName+makeLowerCCLenses :: Name -> DecsQ+makeLowerCCLenses = makeLensesWith lowerCamelCaseLensRules
+ Util/Linter.hs view
@@ -0,0 +1,79 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Linter+  ( LintError(..)+  , Severity(..)+  , LintFormat(..)+  , parseLintFormat+  , reportLintErrors+  ) where++import Data.Aeson (ToJSON(..))+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy.Char8 as ByteString+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import GHC.Generics+import Options.Applicative+import TextShow++import Util.Text++-- Lint Error Types ------------------------------------------------------------++data LintError = LintError+  { source_file :: FilePath+  , source_line :: Int+  , source_col  :: Int+  , severity    :: Severity+  , message     :: Text+  } deriving (Show, Eq, Generic)++instance ToJSON LintError++data Severity = Warning | Error+  deriving (Show, Eq, Generic)++instance ToJSON Severity where+  toJSON Warning = Aeson.String "warning"+  toJSON Error = Aeson.String "error"++-- Options and Parsers ---------------------------------------------------------++data LintFormat+  = HumanReadable+  | JsonDump++parseLintFormat :: Parser LintFormat+parseLintFormat = flag HumanReadable JsonDump $ mconcat+  [ long "json"+  , help "Dump output as JSON"+  ]++-- Outputs ---------------------------------------------------------------------++reportLintErrors :: LintFormat -> [LintError] -> IO ()+reportLintErrors HumanReadable errors+  | null errors = Text.putStrLn "No errors."+  | otherwise = mapM_ (Text.putStrLn . renderLintError) errors+reportLintErrors JsonDump errors = ByteString.putStrLn $ Aeson.encode errors++renderLintError :: LintError -> Text+renderLintError LintError{..} = Text.unlines $+  colorize+  (Text.pack source_file <> ":" <> showt source_line <> ":" <>+   showt source_col <> ": " <> Text.pack (show severity)) :+  wrapText 2 80 message+  where+    colorize x = case severity of+      -- Warning -> Yellow+      Warning -> "\ESC[33m" <> x <> "\ESC[0m"+      -- Error -> Red+      Error   -> "\ESC[31m" <> x <> "\ESC[0m"
+ Util/List.hs view
@@ -0,0 +1,202 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.List+  ( blend+  , chunk+  , count+  , diff+  , equalChunksOf+  , atMostChunksOf+  , splitChunks+  , chunkBy+  , mapHead+  , mapLast+  , mostCommonElem+  , replace+  , sortOnM+  , stripSuffix+  , uniq+  , uniqBy+  ) where++import Data.List+import Data.Ord (comparing)+import qualified Data.Set as Set++-- This is an O(n+m) implementation for computing difference between two lists,+-- when the order of the result is irrelevant.+-- Returns those elements in the first list which are not present in the second.+-- All occurences of repeated elements are removed.+-- eg. [1,1,2,4,3] `List.diff` [1,2] -> [3,4]+diff :: (Eq a, Ord a) => [a] -> [a] -> [a]+diff xs ys = Set.toList $ Set.fromList xs `Set.difference` Set.fromList ys++-- | Returns the number of elements that satisfy the predicate+count :: (a -> Bool) -> [a] -> Int+count f = length . filter f++mapHead :: (a -> a) -> [a] -> [a]+mapHead f (x:xs) = f x : xs+mapHead _ [] = []++mapLast :: (a -> a) -> [a] -> [a]+mapLast f = reverse . mapHead f . reverse++replace :: Eq a => a -> a -> [a] -> [a]+replace a b = map (\x -> if x == a then b else x)++sortOnM :: (Applicative f, Ord b) => (a -> f b) -> [a] -> f [a]+sortOnM f xs =+  map fst . sortOn snd <$> traverse (\x -> (x,) <$> f x) xs++uniq :: Ord a => [a] -> [a]+uniq = Set.toList . Set.fromList++uniqBy :: (a -> a -> Ordering) -> [a] -> [a]+uniqBy cmp = map head . groupBy (\a b -> cmp a b == EQ) . sortBy cmp++-- | Splits list into chunks of roughly equal size 'Int'+-- optimising for variance, which means the chunks can be bigger than the 'Int'+-- and the last chunk can be 50% bigger or 50% smaller than the others.+--+-- > equalChunksOf 25 [1..99] == [ [1..33], [34..66], [67..99]]+-- > equalChunksOf 34 [1..99] == [ [1..49], [50..99] ]+-- > equalChunksOf 49 [1..99] == [ [1..49], [50..99] ]+-- > equalChunksOf 50 [1..99] == [ [1..99] ]+-- > equalChunksOf 51 [1..99] == [ [1..99] ]+--+-- > equalChunksOf 24 [1..99] == [ [1..24], [25..48], [49..72], [73..99] ]+-- >   -- lengths are 24, 24, 24, 27 where last chunk is 3 larger.+-- > map length $ equalChunksOf 6 [1..81] == [6,6,6,6,6,6,6,6,6,6,6,6,9]+-- > last $ map length $ equalChunksOf 24 [1..348] == 36 -- 50% bigger+-- > last $ map length $ equalChunksOf 24 [1..349] == 13 -- 50% smaller+--+-- >+-- > equalChunksOf i [] = [ [] ]+-- > equalChunksOf 0 xs -- *** Exception: divide by zero+-- > equalChunksOf (-1) xs == [ xs ]+equalChunksOf :: Int -> [a] -> [[a]]+equalChunksOf n as = go as size []+  where+    size = length as+    bestLen = size `div` max 1 (size `div` n)+    go bs bsLen acc | bsLen <= bestLen * 3 `div` 2 = reverse $ bs:acc+    go bs bsLen acc =+      let (chunk, rest) = splitAt bestLen bs in+        go rest (bsLen - bestLen) $ chunk:acc++-- | Splits list into non-empty pieces which are at most 'Int' size limit.+-- The actual chunk size will often be smaller (see splitChunks), using+-- the minimum number of chunks to not go over the 'Int' size limit.  The size+-- of chunks will all be equal (if possible) and otherwise vary by at most 1.+--+-- > concat (atMostChunksOf i xs) == xs+-- > all (not . null) (atMostChunksOf i xs)+--+-- > atMostChunksOf 24 [1..99] == [[1..20],[21..40],[41..60],[61..80],[81..99]]+-- > atMostChunksOf 34 [1..99] == [ [1..33], [34..66], [67..99] ]+-- > atMostChunksOf 49 [1..99] == [ [1..33], [34..66], [67..99] ]+-- > atMostChunksOf 50 [1..99] == [ [1..50], [51..99] ]+-- > atMostChunksOf 51 [1..99] == [ [1..50], [51..99] ]+-- >+-- > atMostChunksOf i [] = [] -- never make an empty chunk by returning [ [] ]+-- > atMostChunksOf 1 [x,y,z] = [ [x], [y], [z] ]+-- > atMostChunksOf 0 [x,y,z] = [ [x,y,z] ] -- nonsense, non-empty list+-- > atMostChunksOf (-1) [x,y,z] = [ [x,y,z] ]-- nonsense, non-empty list+atMostChunksOf :: Int -> [a] -> [[a]]+atMostChunksOf i as+    | null as = []+    | i <= 0 = [as]+    | size <= i = [as]+    | otherwise = splitChunks pieces as+  where+    size = length as+    pieces = (size + pred i) `div` i   -- assert size <= pieces * i++-- | Splits list into at most 'Int' non-empty chunks of nearly equal size.+-- Initial larger chunks can be 1 longer than later smaller chunks.+--+-- > concat (splitChunks i xs) == xs+-- > all (not . null) (splitChunks i xs)+--+-- > splitChunks _ [] = [] -- never make an empty chunk by returning [ [] ]+-- > splitChunks 4 [x,y,z] = [ [x], [y], [z] ] -- only 3 non-empty chunks+-- > splitChunks 3 [x,y,z] = [ [x], [y], [z] ]+-- > splitChunks 2 [x,y,z] = [ [x,y], [z] ] -- larger groups first+-- > splitChunks 1 [x,y,z] = [ [x,y,z] ]+-- > splitChunks 0 [x,y,z] = [ [x,y,z] ] -- nonsense, non-empty list+-- > splitChunks (-1) [x,y,z] = [ [x,y,z] ] -- nonsense, non-empty list+splitChunks :: Int -> [a] -> [[a]]+splitChunks b as+    | null as = []+    | b <= 0 = [as]+    | size <= b = map (:[]) as+    | otherwise = go as sizes []+  where+    size = length as+    larges = size `mod` b   -- assert 0 <= larges < b+    smalls = b - larges     -- assert 0 < smalls <= b+    -- assert larges + smalls == b+    smaller = size `div` b  -- assert 1 <= smaller ; since 0 < b < size+    larger = succ smaller   -- assert 2 <= larger+    sizes = replicate larges larger ++ replicate smalls smaller+    -- assert 0 < length sizes == b+    -- assert sum sizes == size+    go [] _ acc = reverse acc      -- base case+    go bs (x:xs) acc =+      let (chunk, rest) = splitAt x bs -- assert 1 <= length chunk+      in go rest xs (chunk:acc)+    go bs [] acc = reverse $ bs:acc -- should not happen++-- | @chunkBy n f xs@: divide @xs@ into chunks of at most size @n@,+-- where the size of an element @x@ of @xs@ is given by @f x@. If the size of+-- any element is greater than @n@, then it will be in a chunk on its own.+--+-- > chunkBy 4 length ["ab", "cde", "f", "ghijk"]+-- > [["ab"],["cde","f"],["ghijk"]]+--+chunkBy :: Int -> (a -> Int) -> [a] -> [[a]]+chunkBy _ _ [] = []+chunkBy chunkSize getSize (x:xs)+  | chunkSize <= 0 = [x:xs]+  | otherwise = go (getSize x) [x] xs+  where+    -- invariant: chunk has at least one element+    go _ chunk [] = [reverse chunk]+    go n chunk (x:xs)+      | n + xSize > chunkSize = reverse chunk : go xSize [x] xs+      | otherwise = go (n + xSize) (x:chunk) xs+      where xSize = getSize x++stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+stripSuffix xs ys+  | Just zs <- stripPrefix (reverse xs) (reverse ys) = Just (reverse zs)+  | otherwise = Nothing++-- | Returns the most common element in the list.+-- Throws if given an empty list.+mostCommonElem :: Ord a => [a] -> a+mostCommonElem = head . maximumBy (comparing length) . group . sort++blend :: [a] -> [a] -> [a]+blend [] _ = []+blend _ [] = []+blend (x:xs) (y:ys) = x:y:blend xs ys++-- | Divide a range @0..(k-1)@ into @n@ chunks. Each pair in the result+-- list is the (start,length) of a chunk.+chunk+  :: Int                                -- ^ @n@+  -> Int                                -- ^ @k@+  -> [(Int,Int)]                        -- ^ @[(start,length)]@+chunk !n !k = zip (scanl (+) 0 lens) lens+  where+    lens = replicate r (q+1) ++ if q == 0 then [] else replicate (n-r) q+    !q = k `div` n+    !r = k `mod` n
+ Util/List/HigherOrder.hs view
@@ -0,0 +1,53 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE PolyKinds #-}+module Util.List.HigherOrder+  ( fold2+  , map2+  , mapMaybe2+  , concatMap2+  , traverse2, traverse2_+  ) where++import Data.Foldable++-- | Efficiently right fold over two lists in sequence that have different+-- parameter types+fold2 :: (forall (z :: k). t z -> b -> b) -> b -> [t x] -> [t y] -> b+fold2 f b xs ys = foldr f (foldr f b ys) xs++-- | Efficiently map a normalizing function over two lists with different type+-- parameters+map2 :: (forall (z :: k). t z -> b) -> [t x] -> [t y] -> [b]+map2 f xs ys = foldr ((:) . f) (map f ys) xs++-- | Like map2, but filter out Nothings+mapMaybe2 :: (forall (z :: k). t z -> Maybe b) -> [t x] -> [t y] -> [b]+mapMaybe2 f = fold2 (maybe id (:) . f) []++concatMap2 :: (forall (z :: k). t z -> [b]) -> [t x] -> [t y] -> [b]+concatMap2 f xs ys = concat $ map2 f xs ys++traverse2+  :: Applicative f+  => (forall (z :: k). t z -> f a)+  -> [t x]+  -> [t y]+  -> f [a]+traverse2 f (x:xs) ys = (:) <$> f x <*> traverse2 f xs ys+traverse2 f [] ys = traverse f ys++traverse2_+  :: Applicative f+  => (forall (z :: k). t z -> f ())+  -> [t x]+  -> [t y]+  -> f ()+traverse2_ f (x:xs) ys = f x *> traverse2_ f xs ys+traverse2_ f [] ys = traverse_ f ys
+ Util/Log.hs view
@@ -0,0 +1,25 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Log+  ( vlog+  , logInfo+  , logWarning+  , logError+  , logFatal+  , flush+  ) where++import Control.Monad.IO.Class+-- Re-export all String-based logging functions for compatibility+-- with existing code.+import Util.Log.String+import Util.Log.Internal++flush :: MonadIO m => m ()+flush = liftIO c_glog_flush
+ Util/Log/Internal.hs view
@@ -0,0 +1,79 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE TemplateHaskell #-}++module Util.Log.Internal+  ( vlogIsOn+  , c_glog_verbose+  , c_glog_info+  , c_glog_warning+  , c_glog_error+  , c_glog_fatal+  , c_glog_flush+  ) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Foreign.C (CString, CInt(..))++import Mangle.TH++$(mangle+  "int vlog_is_on(int)"+  [d|+    foreign import ccall unsafe+      c_vlog_is_on :: CInt -> IO CInt+  |])++$(mangle+  "void glog_verbose(const char*, int, const char*)"+  [d|+    foreign import ccall unsafe+      c_glog_verbose :: CString -> CInt -> CString -> IO ()+  |])++$(mangle+  "void glog_info(const char*, int, const char*)"+  [d|+    foreign import ccall unsafe+      c_glog_info :: CString -> CInt -> CString -> IO ()+  |])++$(mangle+  "void glog_warning(const char*, int, const char*)"+  [d|+    foreign import ccall unsafe+      c_glog_warning :: CString -> CInt -> CString -> IO ()+  |])++$(mangle+  "void glog_error(const char*, int, const char*)"+  [d|+    foreign import ccall unsafe+      c_glog_error :: CString -> CInt -> CString -> IO ()+  |])++$(mangle+  "void glog_fatal(const char*, int, const char*)"+  [d|+    foreign import ccall unsafe+      c_glog_fatal :: CString -> CInt -> CString -> IO ()+  |])++$(mangle+  "void glog_flush()"+  [d|+    foreign import ccall unsafe+      c_glog_flush :: IO ()+  |])++{-# INLINE vlogIsOn #-}+vlogIsOn :: MonadIO m => Int -> m Bool+vlogIsOn level = liftIO $ do+  x <- c_vlog_is_on (fromIntegral level)+  return (x /= 0)
+ Util/Log/String.hs view
@@ -0,0 +1,76 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE ImplicitParams #-}++-- |+-- This module allows you to log things to stderr. Make sure to initialize your+-- application using 'Facebook.Init.initFacebook' or+-- 'Facebook.Init.withFacebook' beforehand. Otherwise you're going to get a+-- cryptic "Logging before InitGoogleLogging() is written to STDERR" error.+module Util.Log.String+  ( vlog+  , vlogIsOn+  , logInfo+  , logWarning+  , logError+  , logFatal+  ) where++import Control.Monad+import Control.Monad.IO.Class (MonadIO, liftIO)+import Foreign.C+import GHC.Stack++import Util.Log.Internal++-- | Equivalent to @VLOG(level)@, except that in Haskell we only evaluate+-- the message if verbosity at the desired level is enabled. Note that+-- this lazy evaluation of the message only applies to 'vlog', not to+-- any of the other logging functions.+vlog :: (MonadIO m, HasCallStack) => Int -> String -> m ()+vlog level msg = liftIO $ do+  b <- vlogIsOn level+  when b $ logCommon c_glog_verbose (getCaller $ getCallStack callStack) msg++-- | The calling point is actually right next to the head as the head is the+-- current function (in this case it would be logInfo/Warning/Error/Fatal).+getCaller :: [(String, SrcLoc)] -> (String, CInt)+getCaller cs =+  case cs of+    -- Take the first element of the stack if it exists+    ((_,sl):_) -> (srcLocFile sl, fromIntegral $ srcLocStartLine sl)+    _       -> ("Unknown stack trace", 0)++-- | Log message at severity level @INFO@.+logInfo :: (MonadIO m, HasCallStack) => String -> m ()+logInfo msg = liftIO $+  logCommon c_glog_info (getCaller $ getCallStack callStack) msg++-- | Log message at severity level @WARNING@.+logWarning :: (MonadIO m, HasCallStack) => String -> m ()+logWarning msg = liftIO $ logCommon c_glog_warning+  (getCaller $ getCallStack callStack) msg++-- | Log message at severity level @ERROR@.+logError :: (MonadIO m, HasCallStack) => String -> m ()+logError msg = liftIO $+  logCommon c_glog_error (getCaller $ getCallStack callStack) msg++-- | Log message at severity level @FATAL@. This will terminate the program+-- after the message is logged.+logFatal :: (MonadIO m, HasCallStack) => String -> m ()+logFatal msg =+  liftIO $ logCommon c_glog_fatal (getCaller $ getCallStack callStack) msg++logCommon :: (CString -> CInt -> CString -> IO ()) ->+             (String, CInt) -> String -> IO ()+logCommon fn (file, lineNumber) msg =+  withCString file $ \file_cstring ->+    withCString msg $ \msg_cstring ->+      fn file_cstring lineNumber msg_cstring
+ Util/Log/Text.hs view
@@ -0,0 +1,78 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE ImplicitParams #-}++-- |+-- This module allows you to log things to stderr. Make sure to initialize your+-- application using 'Facebook.Init.initFacebook' or+-- 'Facebook.Init.withFacebook' beforehand. Otherwise you're going to get a+-- cryptic "Logging before InitGoogleLogging() is written to STDERR" error.+module Util.Log.Text+  ( vlog+  , vlogIsOn+  , logInfo+  , logWarning+  , logError+  , logFatal+  ) where++import Control.Monad+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Text (Text)+import Foreign.C+import GHC.Stack++import Util.Log.Internal+import Util.Text (useTextAsCString)++-- | Equivalent to @VLOG(level)@, except that in Haskell we only evaluate+-- the message if verbosity at the desired level is enabled. Note that+-- this lazy evaluation of the message only applies to 'vlog', not to+-- any of the other logging functions.+vlog :: (MonadIO m, HasCallStack) => Int -> Text -> m ()+vlog level msg = liftIO $ do+  b <- vlogIsOn level+  when b $ logCommon c_glog_verbose (getCaller $ getCallStack callStack) msg++-- | The calling point is actually right next to the head as the head is the+-- current function (in this case it would be logInfo/Warning/Error/Fatal).+getCaller :: [(String, SrcLoc)] -> (String, CInt)+getCaller cs =+  case cs of+    -- Take the first element of the stack if it exists+    ((_,sl):_) -> (srcLocFile sl, fromIntegral $ srcLocStartLine sl)+    _       -> ("Unknown stack trace", 0)++-- | Log message at severity level @INFO@.+logInfo :: (MonadIO m, HasCallStack) => Text -> m ()+logInfo msg =+  liftIO $ logCommon c_glog_info (getCaller $ getCallStack callStack) msg++-- | Log message at severity level @WARNING@.+logWarning :: (MonadIO m, HasCallStack) => Text -> m ()+logWarning msg = liftIO $ logCommon c_glog_warning+  (getCaller $ getCallStack callStack) msg++-- | Log message at severity level @ERROR@.+logError :: (MonadIO m, HasCallStack) => Text -> m ()+logError msg =+  liftIO $ logCommon c_glog_error (getCaller $ getCallStack callStack) msg++-- | Log message at severity level @FATAL@. This will terminate the program+-- after the message is logged.+logFatal :: (MonadIO m, HasCallStack) => Text -> m ()+logFatal msg =+  liftIO $ logCommon c_glog_fatal (getCaller $ getCallStack callStack) msg++logCommon :: (CString -> CInt -> CString -> IO ()) ->+             (String, CInt) -> Text -> IO ()+logCommon fn (file, lineNumber) msg =+  withCString file $ \file_cstring ->+    useTextAsCString msg $ \msg_cstring ->+      fn file_cstring lineNumber msg_cstring
+ Util/LogIfSlow.hs view
@@ -0,0 +1,57 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE CPP #-}+module Util.LogIfSlow (logIfSlow, checkUnsafe) where++import Data.Text (Text)+import Control.Monad+import qualified Data.Text as Text+import Text.Printf+import Util.Timing (timeItNoGC)+import Util.Log.Text as Log++-- | Logs a message (via @Util.Log.log info@) if the given operation takes+-- longer than a specified threshold in seconds.+--+logIfSlow+  :: Double    -- ^ threshold in seconds+  -> Text      -- ^ description, for the log message+  -> IO a      -- ^ the operation to time+  -> IO a+logIfSlow threshold fun io = do+  (t, _, a) <- timeItNoGC io+  when (t > threshold) $+    Log.logInfo $ fun <> " took " <> Text.pack (printf "%.2fs" t)+  return a++-- | Logs a message if an unsafe foreign call takes longer than 1ms,+-- which indicates that it should probably not be marked "unsafe".+--+-- > f = checkUnsafe "c_foo" $ c_foo x y z+-- > foreign import ccall unsafe "foo" c_foo :: ...+--+-- will log a message (via 'Util.Log.info') if the call to @c_foo@ takes+-- longer than 1ms.+--+checkUnsafe :: Text -> IO a -> IO a++#ifdef ENABLE_CHECKUNSAFE++checkUnsafe fun = logIfSlow badUnsafeCallThreshold msg+  where msg = "unsafe foreign call " <> fun++badUnsafeCallThreshold :: Double+badUnsafeCallThreshold = 0.001++#else++checkUnsafe _ io = io+{-# INLINE checkUnsafe #-}++#endif
+ Util/Logger.hs view
@@ -0,0 +1,53 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Logger+  ( ActionLog(..)+  , loggingAction ) where++import Control.Exception+import Data.Int++import Util.Control.Exception (swallow)+import Util.Timing (timeIt)+import GHC.Stack (HasCallStack, withFrozenCallStack)++-- | Logs which can log success, failure and time elapsed+class ActionLog l where+  successLog :: l+  failureLog :: SomeException -> l+  timeLog :: Double -> l+  allocLog :: Int64 -> l++-- | Run an action logging success, failure, time elapsed and data about+-- result.+loggingAction+  :: (ActionLog l, Monoid l, HasCallStack)+  => (l -> IO ())+     -- ^ How to write the log. Typically calls the `runLog` for your+     -- `Logger` instance, and it can augment `l` with additional+     -- information known about this action.+  -> (a -> l)+     -- ^ What to log based on the result of the action+  -> IO a+     -- ^ The action to run+  -> IO a+loggingAction log res io =+  mask $ \restore -> do+    (time,alloc,result) <- timeIt $ try $ restore io+    let+      logOutcome o =+        withFrozenCallStack $+          swallow $ log $ timeLog time `mappend` allocLog alloc `mappend` o+    case result of+      Right x -> do+        logOutcome $ successLog `mappend` res x+        return x+      Left ex -> do+        logOutcome $ failureLog ex+        throwIO ex
+ Util/MD5.hs view
@@ -0,0 +1,24 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.MD5 (md5) where++import GHC.Fingerprint+import Data.ByteString (ByteString)+import Data.ByteString.Unsafe+import Data.Text+import System.IO.Unsafe+import Foreign++import Util.Text++md5 :: ByteString -> Text+md5 bs =+  unsafeDupablePerformIO $+    unsafeUseAsCStringLen bs $ \(ptr,len) ->+      textShow <$> fingerprintData (castPtr ptr) (fromIntegral len)
+ Util/Memory.hs view
@@ -0,0 +1,74 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# OPTIONS_GHC -fno-warn-unused-imports #-}++{-# LANGUAGE CPP #-}++module Util.Memory+  ( alloca+  , allocaBytes+  , allocaBytesAligned+  , allocaArray+  , allocaArray0+  , with+  ) where++import qualified Util.ASan as A+import qualified Foreign as F++{-# INLINE alloca #-}+alloca :: F.Storable a => (F.Ptr a -> IO b) -> IO b+-- TODO(T24195918): We need to do this for ABI compatibility between+-- sigma.service and sigma.service.asan. Codemod to __SANITIZE_ADDRESS__+-- to enable ASAN checks for Haskell allocations.+#ifdef __HASKELL_SANITIZE_ADDRESS__+alloca = A.alloca+#else+alloca = F.alloca+#endif++{-# INLINE allocaBytes #-}+allocaBytes :: Int -> (F.Ptr a -> IO b) -> IO b+#ifdef __HASKELL_SANITIZE_ADDRESS__+allocaBytes = A.allocaBytes+#else+allocaBytes = F.allocaBytes+#endif++{-# INLINE allocaBytesAligned #-}+allocaBytesAligned :: Int -> Int -> (F.Ptr a -> IO b) -> IO b+#ifdef __HASKELL_SANITIZE_ADDRESS__+allocaBytesAligned = A.allocaBytesAligned+#else+allocaBytesAligned = F.allocaBytesAligned+#endif++{-# INLINE allocaArray #-}+allocaArray :: F.Storable a => Int -> (F.Ptr a -> IO b) -> IO b+#ifdef __HASKELL_SANITIZE_ADDRESS__+allocaArray = A.allocaArray+#else+allocaArray = F.allocaArray+#endif++{-# INLINE allocaArray0 #-}+allocaArray0 :: F.Storable a => Int -> (F.Ptr a -> IO b) -> IO b+#ifdef __HASKELL_SANITIZE_ADDRESS__+allocaArray0 = A.allocaArray0+#else+allocaArray0 = F.allocaArray0+#endif++{-# INLINE with #-}+with :: F.Storable a => a -> (F.Ptr a -> IO b) -> IO b+#ifdef __HASKELL_SANITIZE_ADDRESS__+with = A.with+#else+with = F.with+#endif
+ Util/Monoid.hs view
@@ -0,0 +1,23 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Monoid+  ( mwhen+  , munless+  ) where+++-- | Use the supplied value if the condition is 'True',+-- return 'mempty' otherwise. This is like 'guard', but for+-- 'Monoid'.+mwhen :: Monoid m => Bool -> m -> m+mwhen cond v = if cond then v else mempty++-- | The opposite of `mwhen`.+munless :: Monoid m => Bool -> m -> m+munless = mwhen . not
+ Util/Network.hsc view
@@ -0,0 +1,54 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE ForeignFunctionInterface #-}++module Util.Network+  ( ntop6, ntop+  ) where++import Data.ByteString+import Data.Text+import Foreign (nullPtr)+import Foreign.C+import Foreign.Marshal.Alloc (allocaBytes)+import System.IO.Unsafe (unsafePerformIO)++import Util.Text (cStringToText)++ntop' :: Int -> Int -> ByteString -> Maybe Text+ntop' inet' inetAddrStrLen' source =+  unsafePerformIO $ useAsCString source $ \source' ->+    allocaBytes inetAddrStrLen' $ \target -> do+      result <- inet_ntop inet' source' target inet6AddrStrLen+      if result == nullPtr+        then return Nothing+        else Just <$> cStringToText result++ntop6 :: ByteString -> Maybe Text+ntop6 = ntop' inet6 inet6AddrStrLen++ntop :: ByteString -> Maybe Text+ntop = ntop' inet inetAddrStrLen++#include <arpa/inet.h>++inet6AddrStrLen :: Int+inet6AddrStrLen = #{ const INET6_ADDRSTRLEN }++inet6 :: Int+inet6 = #{ const AF_INET6 }++inetAddrStrLen :: Int+inetAddrStrLen = #{ const INET_ADDRSTRLEN }++inet :: Int+inet = #{ const AF_INET }++foreign import ccall unsafe "inet_ntop"+  inet_ntop :: Int -> CString -> CString -> Int -> IO CString
+ Util/OptParse.hs view
@@ -0,0 +1,154 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE CPP #-}+module Util.OptParse+  ( -- * Options+    intOption+  , doubleOption+  , textOption+  , maybeStrOption+  , maybeTextOption+  , maybeIntOption+  , textCommaSplit+  , testCommaSplitAndStrip+  , stringCommaSplit+  , readCommaSplit+  , absFilePathOption+  , relativeFilePathOption+  , maybeAbsFilePathOption+  , maybeRelativeFilePathOption+  , jsonOption+  , showHelpText+    -- * Commands+  , commandParser+    -- * Pure Parser+  , runParserOnString+    -- * Dragons and stuff+  , partialParse+  ) where++import Data.Aeson (FromJSON(..), eitherDecodeStrict')+import Data.Bifunctor (second)+import Data.Char (isSpace)+import qualified Data.List.Split as List+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Encoding (encodeUtf8)+import Options.Applicative+import Options.Applicative.Types++import Util.FilePath+import Util.String+++intOption :: Mod OptionFields Int -> Parser Int+intOption = option auto++doubleOption :: Mod OptionFields Double -> Parser Double+doubleOption = option auto++textOption :: Mod OptionFields Text -> Parser Text+textOption = option (Text.pack <$> str)++maybeStrOption :: Mod OptionFields String -> Parser (Maybe String)+maybeStrOption = optional . option str++maybeTextOption :: Mod OptionFields Text -> Parser (Maybe Text)+maybeTextOption = optional . option (Text.pack <$> str)++maybeIntOption :: Mod OptionFields Int -> Parser (Maybe Int)+maybeIntOption = optional . option (read <$> str)++textCommaSplit :: ReadM [Text]+textCommaSplit = Text.splitOn "," . Text.pack <$> str++testCommaSplitAndStrip :: ReadM [Text]+testCommaSplitAndStrip = map Text.strip <$> textCommaSplit++stringCommaSplit :: ReadM [String]+stringCommaSplit = List.splitOn "," <$> str++readCommaSplit :: Read a => ReadM [a]+readCommaSplit = map (read . strip) <$> stringCommaSplit++jsonOption :: FromJSON a => Mod OptionFields a -> Parser a+jsonOption =+  option (eitherReader $ eitherDecodeStrict' . encodeUtf8 . Text.pack)++-- | Returns an absolute file path, while handling relative paths and ~+absFilePathOption :: DirEnv -> Mod OptionFields FilePath -> Parser FilePath+absFilePathOption e = option (absolutiseWith e <$> str)++-- | Returns a relative file path+relativeFilePathOption :: Mod OptionFields FilePath -> Parser FilePath+relativeFilePathOption = option str+++-- | Returns an absolute file path, while handling relative paths and ~+maybeAbsFilePathOption+  :: DirEnv+  -> Mod OptionFields FilePath+  -> Parser (Maybe FilePath)+maybeAbsFilePathOption e = optional . option (absolutiseWith e <$> str)++-- | Returns a relative file path+maybeRelativeFilePathOption+  :: Mod OptionFields FilePath+  -> Parser (Maybe FilePath)+maybeRelativeFilePathOption = optional . option str++-- | Build a command subparser from a name, description, and parser.+--+-- Example: commandParser "foo" (progDesc "Foo does bar.") (... parser ...)+commandParser+  :: String     -- ^ command name (the 'cmd' in 'prog cmd --cmdflag1')+  -> InfoMod a  -- ^ command description in --help output+  -> Parser a   -- ^ parser of command's flags+  -> Parser a+commandParser cmd desc p =+  subparser $ metavar cmd <> command cmd (info (helper <*> p) desc)++-- | Run given parser on a string.+runParserOnString :: String -> Parser a -> String -> Either String a+runParserOnString cmdName p args =+  case parse of+    Success x -> Right x+    Failure f -> Left $ fst $ renderFailure f cmdName+    CompletionInvoked _ -> Left "Completion Invoked"+  where+    parse = execParserPure+      (prefs mempty) (info (p <**> helper) fullDesc) (quotedWords args)+    recurse (w,s) = w : quotedWords s+    -- Mimic shell's ability to group tokens with double quotes.+    quotedWords s =+      case dropWhile isSpace s of+        "" -> []+        ('"':cs) -> recurse . second tail $ break (=='"') cs+        s' -> recurse $ break isSpace s'++showHelpText :: ParseError+#if MIN_VERSION_optparse_applicative(0,16,0)+showHelpText = ShowHelpText Nothing+#else+showHelpText = ShowHelpText+#endif++-- -----------------------------------------------------------------------------+-- Things from Options.Applicative that have changed++-- | Attempts to parse across *all* arguments, returning ones that were+-- unrecognized. Fails if a required argument is missing.+partialParse :: ParserPrefs -> ParserInfo a -> [String] -> IO (a, [String])+partialParse pprefs pinfo args = handleParseResult res+  where+    pinfo' = pinfo+      { infoParser = (,) <$> infoParser pinfo <*> many (strArgument mempty)+      , infoPolicy = ForwardOptions+      }+    res = execParserPure pprefs pinfo' args
+ Util/Predicate.hs view
@@ -0,0 +1,32 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Predicate+  ( Pred+  , predAnd+  , predTrue+  , predFalse+  ) where++import Control.Applicative (liftA2)++-- | Predicate function.+type Pred a = a -> Bool++-- | Combine two predicate functions to produce a new function that holds if+-- both input predicates hold.+predAnd :: Pred a -> Pred a -> Pred a+predAnd = liftA2 (&&)++-- | Predicate which returns True for all inputs+predTrue :: Pred a+predTrue _ = True++-- | Predicate which returns False for all inputs+predFalse :: Pred a+predFalse _ = False
+ Util/PrettyPrint.hs view
@@ -0,0 +1,72 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.PrettyPrint+  ( renderNumWithUnit+  , renderPercent+  , renderIncrease+  , renderNum+  , renderInt+  , renderBytes+  , renderBytesString+  ) where++import Data.Text (Text)+import qualified Data.Text as Text+import Text.Printf+import TextShow++renderNumWithUnit :: Text -> Double -> Text+renderNumWithUnit unit num = renderNum num <> " " <> unit++-- | Render a fraction as a percentage+renderPercent :: Double -> Double -> Text+renderPercent x y+  | y == 0     = "Infinite"+  | otherwise  = Text.pack $ printf (printf "%%.%df%%%%" precision) frac+  where+    frac = x / y * 100+    -- Make sure we always have enough signifigant digits+    precision = max 0 $ ceiling (negate $ logBase 10 frac) + 2 :: Int++-- | Render an increase as either a percent or times+renderIncrease :: Double -> Double -> Text+renderIncrease x y+  | y == 0    = "Infinite"+  | frac < 2  = renderPercent (x - y) y+  | frac < 10 = Text.pack $ printf "%.2fx" frac+  | otherwise = showt (round frac :: Int) <> "x"+  where+    frac = x / y++renderNum :: Double -> Text+renderNum num+  | num < 10 = Text.pack $ printf "%.2f" num+  | otherwise = renderInt $ round num++renderInt :: Int -> Text+renderInt num+  | num < 1000 = showt num+  | num < 1000000 = showt (num `div` 1000) <> "k"+  | otherwise = showt (num `div` 1000000) <> "M"++renderBytes :: Int -> Text+renderBytes b = Text.pack $ renderBytesString b++renderBytesString :: Int -> String+renderBytesString b+ | b' > gb = printf "%.2f GiB" (b' / gb)+ | b' > mb = printf "%.2f MiB" (b' / mb)+ | b' > kb = printf "%.2f kiB" (b' / kb)+ | otherwise = printf "%d bytes" (fromIntegral b :: Integer)+ where+  kb, mb, gb :: Double+  kb = 1024+  mb = 1024*kb+  gb = 1024*mb+  b' = fromIntegral b :: Double
+ Util/RWVar.hs view
@@ -0,0 +1,52 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.RWVar+  ( RWVar+  , newRWVar+  , withReadRWVar+  , withWriteRWVar+  ) where++import qualified Control.Concurrent.ReadWriteLock as L+import Data.IORef++-- | Var holding a value that's only accessible given access to the lock+-- The lock implementation can starve writers+data RWVar a = RWVar (IORef a) L.RWLock++-- -----------------------------------------------------------------------------+-- Creation++-- | Creates a new var that can be read from or written to+newRWVar :: a -> IO (RWVar a)+newRWVar value = do+  lock <- L.new+  ref <- newIORef value+  return $ RWVar ref lock++-- -----------------------------------------------------------------------------+-- Reading++-- | Obtains a read lock and runs the action with the held value+withReadRWVar :: RWVar a -> (a -> IO b) -> IO b+withReadRWVar (RWVar value lock) action =+  L.withRead lock $ action =<< readIORef value++-- -----------------------------------------------------------------------------+-- Writing++-- | Obtains a write lock and runs the action with the held value.+-- Overwrites the internal value with the newly computed value.+withWriteRWVar :: RWVar a -> (a -> IO (a, b)) -> IO b+withWriteRWVar (RWVar value lock) action =+  L.withWrite lock $ do+    old <- readIORef value+    (new, ret) <- action old+    writeIORef value new+    return ret
+ Util/Reader.hs view
@@ -0,0 +1,59 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Reader+  ( catchR, catchR_+  , bracketR, bracketR_+  , withRetry+  ) where++import Control.Exception+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader++-- | Same as 'catch' from 'Control.Exception', but lifted into a ReaderT+catchR+  :: Exception e+  => ReaderT r IO a+  -> (e -> ReaderT r IO a)+  -> ReaderT r IO a+catchR (ReaderT action) handler = ReaderT $ \env ->+  action env `catch` \e -> runReaderT (handler e) env++-- | Same as 'catchR', but handler doesn't take an argument+catchR_+  :: ReaderT r IO a+  -> ReaderT r IO a+  -> ReaderT r IO a+catchR_ action handler = action `catchR` \SomeException{} -> handler++-- | Same as 'bracket' from 'Control.Exception', but lifted into a ReaderT+bracketR+  :: ReaderT r IO a        -- ^ before+  -> (a -> ReaderT r IO b) -- ^ after+  -> (a -> ReaderT r IO c) -- ^ computation+  -> ReaderT r IO c+bracketR before after thing = ReaderT $ \env ->+  bracket (runReaderT before env)+          (flip runReaderT env . after)+          (flip runReaderT env . thing)++-- | Same as 'bracket_' from 'Control.Exception', but lifted into a ReaderT+bracketR_+  :: ReaderT r IO a -- ^ before+  -> ReaderT r IO b -- ^ after+  -> ReaderT r IO c -- ^ computation+  -> ReaderT r IO c+bracketR_ before after thing =+  bracketR before (const after) (const thing)++-- | Retries the given computation up to n times if it fails.+-- WARNING: only use this with actions that have NO SIDE EFFECTS on failure+withRetry :: Int -> ReaderT r IO a -> ReaderT r IO a+withRetry n action = foldl catchR action $ replicate n $+  \e@SomeException{} -> do lift $ print e ; action
+ Util/STM.hs view
@@ -0,0 +1,62 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++-- | Reexports 'Control.Concurrent.STM'+--   adding logging for deadlocks and utility functions+module Util.STM+ ( updateTVar+ , atomicallyWithLabel+ , Util.STM.atomically+ , module Control.Concurrent.STM+ ) where++import qualified Control.Concurrent.STM as STM+import Control.Concurrent.STM hiding (atomically)+import Control.Exception (Exception, BlockedIndefinitelyOnSTM, catch, throwIO)+import GHC.Stack+import Data.Typeable (Typeable)++-- | version of @modifyTVar'@ that returns the new value+updateTVar :: TVar a -> (a -> a) -> STM a+updateTVar var f = do+  x <- readTVar var+  let !x' = f x+  writeTVar var x'+  return x'++-- | Version of 'atomically' that takes a label+atomicallyWithLabel :: String -> STM a -> IO a+atomicallyWithLabel label stm = do+  STM.atomically stm `catch` (\(_::BlockedIndefinitelyOnSTM) ->+    throwIO (BlockedIndefinitelyOnNamedSTM label))++-- | Version of 'atomically' that labels the transaction using the call site+atomically :: HasCallStack => STM a -> IO a+atomically =+  atomicallyWithLabel (getCaller $ getCallStack callStack)++-- | The calling point is actually right next to the head as the head is the+-- current function (in this case it would be logInfo/Warning/Error/Fatal).+getCaller :: [(String, SrcLoc)] -> String+getCaller cs =+  case cs of+    -- Take the first element of the stack if it exists+    ((_,sl):_) -> prettySrcLoc sl+    _       -> "Unknown stack trace"++-- | 'atomicallyWithLabel' replaces occurrences of 'BlockedIndefinitelyOnSTM' w/+-- 'BlockedIndefinitelyOnNamedSTM', carrying the name of the transaction and+-- thus giving more helpful error messages.+newtype BlockedIndefinitelyOnNamedSTM = BlockedIndefinitelyOnNamedSTM String+    deriving (Typeable)++instance Show BlockedIndefinitelyOnNamedSTM where+    showsPrec _ (BlockedIndefinitelyOnNamedSTM name) =+        showString $ "thread blocked indefinitely in STM transaction: " ++ name++instance Exception BlockedIndefinitelyOnNamedSTM
+ Util/Show.hs view
@@ -0,0 +1,27 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Show+  ( Pretty(..)+  , showBrace+  ) where++-- | Class of human-readable things. Whereas:+--+-- > read (show x) == x+--+-- Humans don't care. Uses 'String' and 'ShowS' for now; if this+-- becomes problematic, it can use 'Text' and 'Builder'.+class Pretty a where+  prettyPrec :: Int -> a -> ShowS+  prettyPrec _ x s = pretty x ++ s+  pretty :: a -> String+  pretty x = prettyPrec 0 x ""++showBrace :: ShowS -> ShowS+showBrace s = showString "{ " . s . showString " }"
+ Util/String.hs view
@@ -0,0 +1,83 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++-- (c) The University of Glasgow 2006++module Util.String+  ( capitalize+  , decapitalize+  , toArgs+  , strip+  ) where++import Data.Char (isSpace, toUpper, toLower)+import Control.Applicative++-- | For processing a string representing a list of arguments into a list of+-- strings, handling surrounding quotes, brackets and spaces. From GHC's Util+-- module. Reproduced here so it can be used without a dependency on GHC.+toArgs :: String -> Either String   -- Error+                           [String] -- Args+toArgs str+    = case dropWhile isSpace str of+      s@('[':_) -> case reads s of+                   [(args, spaces)]+                    | all isSpace spaces ->+                       Right args+                   _ ->+                       Left ("Couldn't read " ++ show str ++ " as [String]")+      s -> toArgs' s+ where+  toArgs' :: String -> Either String [String]+  -- Remove outer quotes:+  -- > toArgs' "\"foo\" \"bar baz\""+  -- Right ["foo", "bar baz"]+  --+  -- Keep inner quotes:+  -- > toArgs' "-DFOO=\"bar baz\""+  -- Right ["-DFOO=\"bar baz\""]+  toArgs' s = case dropWhile isSpace s of+              [] -> Right []+              ('"' : _) -> do+                    -- readAsString removes outer quotes+                    (arg, rest) <- readAsString s+                    (arg:) `fmap` toArgs' rest+              s' -> case break (isSpace <||> (== '"')) s' of+                    (argPart1, s''@('"':_)) -> do+                        (argPart2, rest) <- readAsString s''+                        -- show argPart2 to keep inner quotes+                        ((argPart1 ++ show argPart2):) `fmap` toArgs' rest+                    (arg, s'') -> (arg:) `fmap` toArgs' s''++  readAsString :: String -> Either String (String, String)+  readAsString s = case reads s of+                [(arg, rest)]+                    -- rest must either be [] or start with a space+                    | all isSpace (take 1 rest) ->+                    Right (arg, rest)+                _ ->+                    Left ("Couldn't read " ++ show s ++ " as String")+++(<||>) :: Applicative f => f Bool -> f Bool -> f Bool+(<||>) = liftA2 (||)+infixr 2 <||> -- same as (||)++-- | Strip whitespace from both beginning and end of a string.+strip :: String -> String+strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace++-- | Capitalize the first character of a string.+capitalize :: String -> String+capitalize (x:xs) = toUpper x : xs+capitalize _ = []++-- | Decapitalize the first character of a string+decapitalize :: String -> String+decapitalize (x:xs) = toLower x : xs+decapitalize _ = []
+ Util/String/Quasi.hs view
@@ -0,0 +1,30 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE TemplateHaskell #-}+module Util.String.Quasi (s) where++import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Data.String++-- | An easy way to write multiline string literals using QuasiQuotes. Useful+-- for e.g. large JSON literals.+--+-- >  [s| this+-- >    is a+-- >    multi-line string literal with \no escaping\+-- >  |]+--+s :: QuasiQuoter+s = QuasiQuoter {+    quoteExp  = \str -> return $ AppE (VarE 'fromString) $ LitE $ StringL str,+    quotePat  = \_ -> fail "quotePat",+    quoteType = \_ -> fail "quoteType",+    quoteDec  = \_ -> fail "quoteDec"+}
+ Util/Testing.hs view
@@ -0,0 +1,84 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE NamedFieldPuns #-}+module Util.Testing+  ( assertProperty+  , assertPropertyWithArgs+  , QC.stdArgs+  , QC.Args(..)+  , skip+  , skipTest+  , skipTestIf+  , skipTestIfRtsIsProfiled+  , skipIf+  ) where++import Control.Exception+import GHC.Stack (HasCallStack)+import System.Environment (lookupEnv)+import System.IO+import Test.HUnit+import Test.HUnit.Lang (HUnitFailure)+import Util.Control.Exception+import qualified Test.QuickCheck as QC++skip :: String -> IO ()+skip msg = hPutStr stderr $ unlines [msg, "***SKIP***"]++skipIf :: (SomeException -> Bool) -> IO () -> IO ()+skipIf f = handleAll $ \e -> if f e then skip (show e) else throw e++skipTestIf :: (SomeException -> Bool) -> Test -> Test+skipTestIf f (TestCase tc) = TestCase $ skipIf f tc+skipTestIf f (TestList ts) = TestList $ map (skipTestIf f) ts+skipTestIf f (TestLabel l t) = TestLabel l $ skipTestIf f t++skipTest :: Test -> Test+skipTest = skipTestIf $ const True++skipTestIfRtsIsProfiled :: Test -> Test+skipTestIfRtsIsProfiled = skipTestIf $ const (rtsIsProfiled /= 0)++assertProperty+  :: (HasCallStack, QC.Testable prop) => String -> prop -> Assertion+assertProperty msg prop =+  assertPropertyWithArgs msg QC.stdArgs prop++assertPropertyWithArgs+  :: (HasCallStack, QC.Testable prop) => String -> QC.Args -> prop -> Assertion+assertPropertyWithArgs msg qcArgs prop = do+  size <- maybe (QC.maxSize qcArgs) read <$> lookupEnv "QUICKCHECK_SIZE"+  success <-+    maybe (QC.maxSuccess qcArgs) read <$> lookupEnv "QUICKCHECK_RUNS"+  mbSeed <- lookupEnv "QUICKCHECK_SEED"+  let args = qcArgs {+        QC.maxSize = size,+        QC.maxSuccess = success,+        QC.replay = (,size) . read <$> mbSeed+      }+  case QC.replay args of+    Just r -> putStrLn $ "Running with replay: " <> show r+    _ -> pure ()+  result <- QC.quickCheckWithResult args prop+  case result of+    QC.Success{} -> return ()+    QC.Failure{theException = Just e}+      | Just (he :: HUnitFailure) <- fromException e -> throwIO he+    QC.Failure{usedSeed, usedSize}+     -> assertFailure $ unlines $+      [ msg+      , "To reproduce, set:"+      , "- QUICKCHECK_SEED=" <> show (show usedSeed)+      ] <>+      [ "- QUICKCHECK_SIZE=" <> show usedSize+      | usedSize /= QC.maxSize QC.stdArgs+      ]+    _ -> assertFailure msg++foreign import ccall unsafe "rts_isProfiled" rtsIsProfiled :: Int
+ Util/Text.hs view
@@ -0,0 +1,419 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# OPTIONS_GHC -fno-warn-unused-imports #-}++{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE CPP #-}++module Util.Text+  ( cStringLenToText+  , cStringLenToTextAndByteString+  , cStringLenToTextLenient+  , cStringToText+  , cStringToTextLenient+  , newCStringFromText+  , useMaybeTextAsCString+  , useTextAsCString+  , useTextAsCStringLen+  , useTextsAsCStrings+  , useTextsAsCStringLens+  , withCStrings+  , textShow+  , TextRead(..)+  , TextAndByteString(..)+  , TextOrByteString(..)+  , mkTextAndByteString+  , nl+  , capitalize+  , decapitalize+  , insertCommasAndAnd+  , toCamelCase+  , toPascalCase+  , toText+  , toUnderscore+  , isCfInfixOf+  , UnicodeException+  , Util.Text.withCStringLen+  , useAsPtr+  , InvalidConversion(..)+  , textToInt+  , hexToInt+  , hexToBytes+  , wrapText+  , slice+  ) where++import Control.Arrow (first)+import Control.Exception (Exception, throw)+import qualified Data.Text.Array as A+import Data.Binary+import Data.ByteString (ByteString, useAsCStringLen)+import qualified Data.ByteString as BS+import Data.Char+import Data.Function (on)+import Data.Hashable (Hashable(..))+import qualified Data.HashMap.Strict as HashMap+import Data.String+import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8', decodeUtf8With)+import Data.Text.Encoding.Error (UnicodeException, lenientDecode)+import Data.Typeable+import Foreign+import Foreign.C+import qualified Data.ByteString.Char8 as Char8+import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.Text as Text+import Data.Text.Internal+import qualified Data.Text.Foreign as Text++import TextShow hiding (toText)+import Util.ByteString+import qualified Util.ASan as ASan++-- | Executes an 'IO' action with an array of 'CString's marshalled from+-- 'String'.+withCStrings :: [String] -> (Ptr CString -> IO a) -> IO a+withCStrings strs f = go [] strs+  where go cs (t:ts) = withCString t $ \c -> go (c:cs) ts+        go cs [] = withArray0 nullPtr (reverse cs) f++-- | Converts a null-terminated 'CString' to 'Text'.+cStringToText :: CString -> IO Text+cStringToText s = do+  bs <- B.unsafePackCString s+  return $! decodeUtf8 bs+++cStringToTextLenient :: CString -> IO Text+cStringToTextLenient s = do+  bs <- B.unsafePackCString s+  return $! decodeUtf8With lenientDecode bs++-- | Converts a 'CString' with known length to 'Text'.+cStringLenToText :: CString -> Int -> IO Text+cStringLenToText s len = do+  bs <- B.unsafePackCStringLen (s, len)+  return $! decodeUtf8 bs++cStringLenToTextAndByteString :: CString -> Int -> IO TextAndByteString+cStringLenToTextAndByteString s len = do+  bs <- Char8.packCStringLen (s, len)+  return $! mkTextAndByteString bs++cStringLenToTextLenient :: CString -> Int -> IO Text+cStringLenToTextLenient s len = do+  bs <- B.unsafePackCStringLen (s, len)+  return $! decodeUtf8With lenientDecode bs++-- | Executes an 'IO' action with a 'CString' marshalled from 'Just'+-- 'Text', or a 'nullPtr' from 'Nothing'.+useMaybeTextAsCString :: Maybe Text -> (CString -> IO a) -> IO a+useMaybeTextAsCString (Just text) m = useTextAsCString text m+useMaybeTextAsCString Nothing m = m nullPtr++-- | Executes an 'IO' action with a 'Text' value marshalled as a UTF-8+-- 'CString'.+useTextAsCString :: Text -> (CString -> IO a) -> IO a+-- TODO(T24195918): We need to do this for ABI compatibility between+-- sigma.service and sigma.service.asan. Codemod to __SANITIZE_ADDRESS__+-- to enable ASAN checks for Haskell allocations.+#ifdef __HASKELL_SANITIZE_ADDRESS__+useTextAsCString = ASan.textWithCString+#else+useTextAsCString = BS.useAsCString . encodeUtf8+#endif++-- | Executes an 'IO' action with a 'Text' value marshalled as a UTF-8+-- 'CStringLen'.+useTextAsCStringLen :: Text -> (CStringLen -> IO a) -> IO a+#ifdef __HASKELL_SANITIZE_ADDRESS__+useTextAsCStringLen = ASan.textWithCStringLen+#else+useTextAsCStringLen = BS.useAsCStringLen . encodeUtf8+#endif++-- | Executes an 'IO' action with a '[Text]' value marshalled as a UTF-8+-- 'Ptr CStringLen'.+useTextsAsCStringLens :: [Text]+                      -> (Ptr CString -> Ptr CSize -> CSize -> IO a)+                      -> IO a+useTextsAsCStringLens = bsListAsCStrLenArr . map encodeUtf8++{-# INLINE withCStringLen #-}+withCStringLen :: Text -> (CStringLen -> IO a) -> IO a+#ifdef __HASKELL_SANITIZE_ADDRESS__+withCStringLen = ASan.textWithCStringLen+#else+withCStringLen = Text.withCStringLen+#endif++-- | Executes an 'IO' action with an array of 'CStrings' marshalled from+-- 'Text'.+useTextsAsCStrings :: [Text] -> (Ptr CString -> IO a) -> IO a+useTextsAsCStrings texts f = go [] texts+  where+  go cs (t:ts) =+    Util.ByteString.useAsCString (encodeUtf8 t) $ \c -> go (c:cs) ts+  go cs [] = withArray0 nullPtr (reverse cs) f++-- | Converts a 'Text' to a 'CString'. The resulting 'CString' must be+-- 'free'd.+newCStringFromText :: Text -> IO CString+newCStringFromText = newCStringFromLazyByteString+  . B.fromChunks . (:[]) . encodeUtf8++-- | A convenience wrapper for 'Show'.+textShow :: Show a => a -> Text+textShow = Text.pack . show++{-# INLINE useAsPtr #-}+useAsPtr :: Text -> (Ptr Word16 -> Text.I16 -> IO a) -> IO a+#ifdef __HASKELL_SANITIZE_ADDRESS__+useAsPtr = ASan.textUseAsPtr+#else+useAsPtr = Text.useAsPtr+#endif++-- | A pair of a 'Text' and a 'ByteString'. Useful for when we get a+-- value in one format and we want to lazily compute and cache the+-- conversion to the other format.+--+-- /Note:/ if/when conversion is free (i.e. 'Text' is stored as UTF-8)+-- then we can get rid of this.++data TextAndByteString = TextAndByteString+  { toTextOrError :: Either UnicodeException Text -- deliberately lazy+  , toByteString :: ByteString }+  deriving Typeable++toText :: TextAndByteString -> Text+toText v+  = case toTextOrError v of+      Left e -> throw e+      Right v -> v++instance Eq TextAndByteString where+  a == b = toByteString a == toByteString b++instance Binary TextAndByteString where+  put = put . toByteString+  get = mkTextAndByteString <$> get++-- We don't need to show both fields, and indeed the contents might+-- not be valid Text, so the Show instance must show only the+-- ByteString component.+instance Show TextAndByteString where+  showsPrec p tbs =+    showParen (p > 10)+    $ showString "mkTextAndByteString "+    . shows (Char8.unpack (fromTextAndByteString tbs))+    -- the showParen is necessary so that instead of e.g.+    --    Foo mkTextAndByteString ""+    -- we get+    --    Foo (mkTextAndByteString "")++instance Hashable TextAndByteString where+  hashWithSalt s = hashWithSalt s . toByteString++-- | Type-specialised constructor+mkTextAndByteString :: ByteString -> TextAndByteString+mkTextAndByteString = toTextAndByteString++instance IsString TextAndByteString where+  fromString xs = toTextAndByteString (Text.pack xs)++class TextOrByteString a where+  fromTextAndByteString :: TextAndByteString -> a+  toTextAndByteString :: a -> TextAndByteString++instance TextOrByteString Text where+  fromTextAndByteString = toText+  toTextAndByteString txt = TextAndByteString {+    toByteString = encodeUtf8 txt,+    toTextOrError = Right txt+  }++instance TextOrByteString ByteString where+  fromTextAndByteString = toByteString+  toTextAndByteString str = TextAndByteString {+    toByteString = str,+    toTextOrError = decodeUtf8' str+  }+++-- | Create a number of newlines.+nl :: Int -> Text+nl = flip Text.replicate "\n"++-- | Capitalize the first non-whitespace character of a Text string.+capitalize :: Text -> Text+capitalize s = ws <> c <> cs+  where+    (ws, s') = Text.span isSpace s+    (c, cs) = first Text.toUpper . Text.splitAt 1 $ s'++-- | Lowercase the first non-whitespace character of a Text string.+decapitalize :: Text -> Text+decapitalize s =+  case Text.uncons t of+    Just (c, cs) | c /= toLower c -> ws <> Text.cons (toLower c) cs+    _ -> s+  where+    (ws, t) = Text.span isSpace s++toCamelCase :: Text -> Text+toCamelCase = decapitalize . toPascalCase++toPascalCase :: Text -> Text+toPascalCase t = Text.concat $ map capitalize (Text.splitOn "_" t)++toUnderscore :: Text -> Text+toUnderscore t = Text.intercalate "_" $+  map Text.toLower $ Text.groupBy (\_ i -> not $ isUpper i) t++-- | Search for substring whilst ignoring case.+isCfInfixOf :: Text -> Text -> Bool+isCfInfixOf = Text.isInfixOf `on` Text.toCaseFold++class TextRead a where+  readText :: Text -> Maybe a++  -- Default implementation for enumerations+  default readText :: (Bounded a, Enum a, TextShow a) => Text -> Maybe a+  readText =+    let+      m = HashMap.fromList [ (showt v, v) | v <- [minBound..maxBound] ]+    in \t -> HashMap.lookup t m+  {-# INLINE readText #-}++newtype InvalidConversion = InvalidConversion Text+  deriving (Typeable, Eq, Show)++instance Exception InvalidConversion++-- | Attempts to convert a decimal representation of an integer to an+-- 'Int'.  Returns 'Left' with an error message if the input 'Text'+-- was not a valid integer, or 'Right' with the value otherwise.+textToInt :: Text -> Either InvalidConversion Int+textToInt txt@(Text arr off len)+  | len == 0 = err+  | fromIntegral (A.unsafeIndex arr off) == ord '-' =+    if len > 1+       then negate <$> go 0 (off+1)+       else err+  | otherwise = go 0 off+  where+  -- Use Text internals for speed.  We know that digits are never in+  -- the upper range of UTF-16.+  go !n !i+    | i == len + off = Right n+    | c >= 0 && c <= 9 = go (n * 10 + c) (i + 1)+    | otherwise = err+    where+      c = fromIntegral (A.unsafeIndex arr i) - ord '0'++  err = Left . InvalidConversion $+    "textToInt: string \"" <> txt <> "\" is not an integer"++-- | Attempts to convert a hexadecimal representation of an integer to an+-- 'Int'.  Returns 'Left' with an error message if the input 'Text'+-- was not a valid integer, or 'Right' with the value otherwise.+hexToInt :: Text -> Either InvalidConversion Int+hexToInt txt@(Text arr off len)+  | len == 0 = err+  | fromIntegral (A.unsafeIndex arr off) == ord '-' =+    if len > 1+       then negate <$> go 0 (off+1)+       else err+  | otherwise = go 0 off+  where+  -- Use Text internals for speed.  We know that digits are never in+  -- the upper range of UTF-16.+  go !n !i+    | i == len + off = Right n+    | c >= ord '0' && c <= ord '9' = go (n * 16 + c - ord '0') (i + 1)+    | c >= ord 'a' && c <= ord 'f' = go (n * 16 + c - ord 'a' + 10) (i + 1)+    | c >= ord 'A' && c <= ord 'F' = go (n * 16 + c - ord 'A' + 10) (i + 1)+    | otherwise = err+    where+      c = fromIntegral (A.unsafeIndex arr i)++  err = Left $ InvalidConversion $+          "hexToInt: string \"" <> txt <> "\" is not an integer"++-- | Convert a hexadecimal representation of an integer to a+-- big-endian ByteString.+hexToBytes :: Text -> Either InvalidConversion ByteString+hexToBytes txt@(Text arr off len)+  | len == 0 = err+  | otherwise = go [] (off+len-1)+  where+  go acc !i+    | i < off = Right (BS.pack acc)+    | i == off, Just x <- nibble l = Right (BS.pack (x:acc))+    | Just x <- nibble l, Just y <- nibble h =+        go (y `shiftL` 4 + x : acc) (i-2)+    | otherwise = err+    where+      l = fromIntegral (A.unsafeIndex arr i)+      h = fromIntegral (A.unsafeIndex arr (i-1))++  {-# INLINE nibble #-}+  nibble :: Int -> Maybe Word8+  nibble x+    | x >= ord '0' && x <= ord '9' = Just (fromIntegral (x - ord '0'))+    | x >= ord 'a' && x <= ord 'f' = Just (10 + fromIntegral (x - ord 'a'))+    | otherwise = Nothing++  err = Left $ InvalidConversion $+    "hexToBytes: string \"" <> txt <> "\" is not a hex integer"++insertCommasAndAnd :: [Text] -> Text+insertCommasAndAnd [] = ""+insertCommasAndAnd [x] = x+insertCommasAndAnd [x, y] = x <> " and " <> y+insertCommasAndAnd [x, y, z] = x <> ", " <> y <> ", and " <> z+insertCommasAndAnd (x : xs) = x <> ", " <> insertCommasAndAnd xs++-- | Break a Text into lines such that each one fits within the given number of+-- characters.+-- NB: this function does not preserve existing whitespace formatting.+wrapText+  :: Int  -- ^ Indent Amount+  -> Int  -- ^ Max characters per line+  -> Text -- ^ Text to wrap+  -> [Text]+wrapText indent maxLength text = concatMap wrapLine $ Text.lines text+  where+    wrapLine line = case Text.words line of+      [] -> []+      [word] -> [word]+      w:ws -> wrap (margin <> w) (indent + Text.length w) ws++    wrap acc _ [] = [acc]+    wrap acc n (w:ws)+      -- If adding the word exceeds the limit, then wrap+      | len > maxLength = acc : wrap (margin <> w) (indent + Text.length w) ws+      -- Otherwise, add to the current line. Not that there is no length check+      -- here. If the word is longer than the max line length then we will put+      -- it in anyway.+      | otherwise = wrap (acc <> " " <> w) len ws+      where+        len = n + Text.length w + 1+    margin = Text.replicate indent " "++-- | The obvious implementation has a performance bug in platform < 011:+--    https://github.com/channable/haskell-string-slicing-benchmarks+slice :: Int -> Int -> Text -> Text+#if MIN_VERSION_text(2,0,0)+slice from len = Text.take len . Text.drop from+#else+slice from len t =+  let !t' = Text.drop from t in Text.take len t'+#endif
+ Util/Time.hs view
@@ -0,0 +1,150 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE NamedFieldPuns #-}+module Util.Time+  ( -- * absolute time+    EpochClock(..)+  , getEpochTime, toEpochSeconds, toEpochNanos+  , epochClockToUTCTime, showUTC, readUTC+  , showEpochTime+    -- * time point differences+  , TimePoint(..), DiffTimePoints(..), getTimePoint+  , addToTimePoint+  , diffTimePoints, addDiffTimePoints+  , getElapsedTime, elapsedTime+  , toDiffMillis, toDiffMicros, toDiffNanos, toDiffSeconds+    -- * utils+  , delay, nanoseconds, seconds, minutes, hours+  ) where++import Control.Concurrent+import Data.Ratio+import qualified Data.Text as T+import qualified Data.Time.Clock as TC ( UTCTime )+import Data.Time.Clock.POSIX ( posixSecondsToUTCTime, POSIXTime )+import Data.Time.Format ( defaultTimeLocale, formatTime, parseTimeM )+import qualified System.Clock as SC++import Compat.Prettyprinter as P++newtype EpochClock = EpochClock SC.TimeSpec deriving (Eq, Ord, Show)++-- | Use 'Clock' of 'Realtime'+getEpochTime :: IO EpochClock+getEpochTime = EpochClock <$> SC.getTime SC.Realtime++-- | Using this with 'getEpochTime' and 'showEpochTime' agrees with running+--+-- > /usr/local/bin/date +'%s'+toEpochSeconds :: EpochClock -> Double+toEpochSeconds (EpochClock SC.TimeSpec{sec, nsec}) = fromRational $+  fromIntegral sec + (fromIntegral nsec % 1000000000)++toEpochNanos :: EpochClock -> Integer+toEpochNanos (EpochClock timeSpec) = SC.toNanoSecs timeSpec++-- | Using this with 'getEpochTime' and 'showEpochTime' agrees with running+--+-- > /usr/local/bin/date --rfc-3339=ns+epochClockToUTCTime :: EpochClock -> TC.UTCTime+epochClockToUTCTime (EpochClock SC.TimeSpec{sec, nsec}) =+  let posixSeconds :: POSIXTime+      posixSeconds = fromRational $+        fromIntegral sec + (fromIntegral nsec % 1000000000)+  in posixSecondsToUTCTime posixSeconds++-- | For seconds, this has variable number of digits after decimal point.+-- We want to log RFC 3339 format+showUTC :: TC.UTCTime -> T.Text+showUTC = T.pack . formatTime defaultTimeLocale "%FT%X%QZ"++readUTC :: T.Text -> Maybe TC.UTCTime+readUTC = parseTimeM True defaultTimeLocale "%FT%X%QZ" . T.unpack++-- | We want to log RFC 3339 format+showEpochTime :: EpochClock -> T.Text+showEpochTime = showUTC . epochClockToUTCTime++-- -----------------------------------------------------------------------------++newtype TimePoint = TimePoint SC.TimeSpec deriving (Eq, Ord, Show)++instance P.Pretty TimePoint where+  pretty (TimePoint SC.TimeSpec{..}) = P.pretty $ "TimePoint "+    <> T.pack (show sec) <> "." <> T.justifyRight 9 '0' (T.pack (show nsec))++-- | Use 'Clock' of 'MonotonicRaw'+getTimePoint :: IO TimePoint+getTimePoint = TimePoint <$> SC.getTime SC.MonotonicRaw++newtype DiffTimePoints = DiffTimePoints SC.TimeSpec+  deriving (Eq, Ord, Show, Num)++instance P.Pretty DiffTimePoints where+  pretty (DiffTimePoints SC.TimeSpec{..}) = P.pretty $ "DiffTimePoints "+    <> T.pack (show sec) <> "." <> T.justifyRight 9 '0' (T.pack (show nsec))++addDiffTimePoints :: DiffTimePoints -> DiffTimePoints -> DiffTimePoints+addDiffTimePoints (DiffTimePoints a) (DiffTimePoints b) = DiffTimePoints (a+b)++-- | This takes the earlier (smaller) then the later (larger) 'TimePoint'+diffTimePoints :: TimePoint -> TimePoint -> DiffTimePoints+diffTimePoints (TimePoint small) (TimePoint big) =+  DiffTimePoints (big - small)++addToTimePoint :: TimePoint -> DiffTimePoints -> TimePoint+addToTimePoint (TimePoint time) (DiffTimePoints diff) =+  TimePoint (time + diff)++getElapsedTime :: TimePoint -> IO DiffTimePoints+getElapsedTime small = do+  big <- getTimePoint+  return (diffTimePoints small big)++-- | Measure the elapsed time of an IO action+elapsedTime :: IO a -> IO (DiffTimePoints, a)+elapsedTime io = do+  t0 <- getTimePoint+  a <- io+  delta <- getElapsedTime t0+  return (delta, a)++-- | We want to log milliseconds, use 'round'+toDiffMillis :: DiffTimePoints -> Int+toDiffMillis (DiffTimePoints SC.TimeSpec{sec,nsec}) =+  1000 * fromIntegral sec ++    (round :: Rational -> Int) (fromIntegral nsec % 1000000)++toDiffMicros :: DiffTimePoints -> Int+toDiffMicros (DiffTimePoints SC.TimeSpec{sec,nsec}) =+  1000000 * fromIntegral sec ++    (round :: Rational -> Int) (fromIntegral nsec % 1000)++toDiffNanos :: DiffTimePoints -> Int+toDiffNanos (DiffTimePoints SC.TimeSpec{sec,nsec}) =+  1000000000 * fromIntegral sec + fromIntegral nsec++toDiffSeconds :: DiffTimePoints -> Double+toDiffSeconds (DiffTimePoints SC.TimeSpec{sec,nsec}) =+  fromIntegral sec + 1e-9 * fromIntegral nsec++delay :: DiffTimePoints -> IO ()+delay = threadDelay . toDiffMicros++nanoseconds :: Int -> DiffTimePoints+nanoseconds n = DiffTimePoints (SC.fromNanoSecs (fromIntegral n))++seconds :: Int -> DiffTimePoints+seconds s = DiffTimePoints (SC.TimeSpec (fromIntegral s) 0)++minutes :: Int -> DiffTimePoints+minutes m = seconds (m * 60)++hours :: Int -> DiffTimePoints+hours h = minutes (h * 60)
+ Util/TimeSec.hs view
@@ -0,0 +1,179 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++-- | Utilities for dealing with time in seconds. This is mostly for+-- interacting with external systems that store or communicate using+-- time in seconds. For higher-resolution times, see "Util.Timing".+module Util.TimeSec+  ( Time(..)+  , TimeSpan(..)+  , TimeRange(..)+  , fromUTCTime+  , toUTCTime+  , addTime, subTime, timeDiff+  , addTimeSpan+  , now, timeAgo+  , minutes, hours, days, weeks+  , minute, hour, day, week+  , toSeconds, toMinutes, toHours, toDays+  , trBetween+  , trLength+  , trLast+  , ppUTCTime, ppDate, ppTime, ppTimeSpan, ppTimeSpanWithGranularity+  , PPTimeSpanGranularity(..)+  , showNominalDiffTime+  ) where++import Data.Aeson+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time.Clock+import Data.Time.Clock.POSIX+import Data.Time.Format+import Data.Maybe (catMaybes)+import TextShow++import GHC.Generics+import Control.DeepSeq+import Data.Hashable++-- | Unix timestamp. Time in seconds+newtype Time = Time { timeInSeconds :: Int }+  deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON, TextShow, Num, Enum)++instance NFData   Time+instance Hashable Time++-- | 'TimeSpan' means a time difference, duration in seconds,+-- as opposed to 'Time', which is a specific point in time+-- (a unix timestamp).+newtype TimeSpan = TimeSpan { timeSpanInSeconds :: Int }+                 deriving (Show, Eq, Ord)++data TimeRange = TimeRange+  { start :: Time+  , end :: Time+  } deriving (Show, Eq)++fromUTCTime :: UTCTime -> Time+fromUTCTime = Time . truncate . utcTimeToPOSIXSeconds++toUTCTime :: Time -> UTCTime+toUTCTime (Time t) = posixSecondsToUTCTime $ fromIntegral t++addTime :: Time -> TimeSpan -> Time+addTime (Time t) (TimeSpan d) = Time (t + d)++subTime :: Time -> TimeSpan -> Time+subTime (Time t) (TimeSpan d) = Time (t - d)++timeDiff :: Time -> Time -> TimeSpan+timeDiff (Time e) (Time s) = TimeSpan (e - s)++negateTimeSpan :: TimeSpan -> TimeSpan+negateTimeSpan TimeSpan{..} = TimeSpan (- timeSpanInSeconds)++addTimeSpan :: TimeSpan -> TimeSpan -> TimeSpan+addTimeSpan t1 t2 = TimeSpan $ timeSpanInSeconds t1 + timeSpanInSeconds t2++now :: IO Time+now = fromUTCTime <$> getCurrentTime++timeAgo :: TimeSpan -> IO Time+timeAgo d = (`subTime` d) <$> now++minutes, hours, days, weeks :: Int -> TimeSpan+minutes = TimeSpan . (60 *)+hours = TimeSpan . (3600 *)+days = TimeSpan . (86400 *)+weeks = TimeSpan . (604800 *)++minute, hour, day, week :: TimeSpan+minute = minutes 1+hour = hours 1+day = days 1+week = weeks 1++trLength :: TimeRange -> TimeSpan+trLength (TimeRange s e) = timeDiff e s++trLast :: TimeSpan -> IO TimeRange+trLast d = trBetween d (TimeSpan 0)++trBetween :: TimeSpan -> TimeSpan -> IO TimeRange+trBetween startDiff endDiff = do+  t <- now+  return TimeRange+    { start = t `subTime` startDiff+    , end = t `subTime` endDiff+    }++-- Some generally useful pretty printing functions -----------------------------++ppUTCTime :: FormatTime t => t -> Text+ppUTCTime t = ppDate t <> " at " <> ppTime t++ppDate :: FormatTime t => t -> Text+ppDate = Text.pack . formatTime defaultTimeLocale "%F"  -- e.g. 2017-07-20++ppTime :: FormatTime t => t -> Text+ppTime = Text.pack . formatTime defaultTimeLocale "%T UTC"  -- e.g. 14:18:45++data PPTimeSpanGranularity = Day | Hour | Minute | Second++secondsInOneDay :: Int+secondsInOneDay = 3600 * 24++toDays, toHours, toMinutes, toSeconds :: TimeSpan -> Int+toDays TimeSpan{..}  = timeSpanInSeconds `div` secondsInOneDay+toHours TimeSpan{..}  = (timeSpanInSeconds `mod` secondsInOneDay) `div` 3600+toMinutes TimeSpan{..} = (timeSpanInSeconds `mod` 3600) `div` 60+toSeconds TimeSpan{..} = timeSpanInSeconds `mod` 60++plural :: Int -> Text -> Maybe Text+plural 0 _       = Nothing+plural 1 unitStr = Just $ "1 " <> unitStr+plural n unitStr = Just $ showt n <> " " <> unitStr <> "s"++joinTimeSectionString :: Text -> [Maybe Text] -> Text+joinTimeSectionString unitStr maybeSecs = case catMaybes maybeSecs of+  [] -> "0" <> unitStr <> "s"+  s  -> Text.intercalate ", " s++ppTimeSpanWithGranularity :: PPTimeSpanGranularity -> TimeSpan -> Text+ppTimeSpanWithGranularity g ts | timeSpanInSeconds ts < 0 =+  "-" <> ppTimeSpanWithGranularity g (negateTimeSpan ts)+ppTimeSpanWithGranularity Day ts+  | timeSpanInSeconds ts < secondsInOneDay = ppTimeSpanWithGranularity Hour ts+  | otherwise = joinTimeSectionString "day" [ plural (toDays ts) "day" ]+ppTimeSpanWithGranularity Hour ts+  | timeSpanInSeconds ts < 3600 = ppTimeSpanWithGranularity Minute ts+  | otherwise = joinTimeSectionString "hour"+    [ plural (toDays ts) "day"+    , plural (toHours ts) "hour"+    ]+ppTimeSpanWithGranularity Minute ts+  | timeSpanInSeconds ts < 60 = ppTimeSpanWithGranularity Second ts+  | otherwise = joinTimeSectionString "minute"+    [ plural (toDays ts) "day"+    , plural (toHours ts) "hour"+    , plural (toMinutes ts) "minute"+    ]+ppTimeSpanWithGranularity Second ts =+  joinTimeSectionString "second"+    [ plural (toDays ts) "day"+    , plural (toHours ts) "hour"+    , plural (toMinutes ts) "minute"+    , plural (toSeconds ts) "second"+    ]++ppTimeSpan :: TimeSpan -> Text+ppTimeSpan = ppTimeSpanWithGranularity Second++showNominalDiffTime :: NominalDiffTime -> String+showNominalDiffTime t = Text.unpack (ppTimeSpan (TimeSpan (round t)))
+ Util/Timing.hs view
@@ -0,0 +1,88 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++-- | Utilities for timing things and working with time differences+module Util.Timing+  ( reportTime+  , reportAndShowTime+  , showAllocs+  , showTime+  , timeIt+  , timeNF+  , timeItNoGC+  ) where++import Control.DeepSeq (NFData, force)+import Control.Exception (evaluate)+import Control.Monad.IO.Class+import Data.Int+import Text.Printf+import GHC.Stats+import GHC.Conc+import System.IO (stderr)++import Util.PrettyPrint+import Util.Time++-- | Runs an 'IO' operation and prints how long it took. Also returns+-- the timing value for use.+reportAndShowTime :: MonadIO m => String -> m a -> m (Double, Int64, a)+reportAndShowTime name io = do+  (t, b, a) <- timeIt io+  liftIO $ hPrintf stderr "%s: %s, %s\n" name (showTime t) (showAllocs b)+  return (t, b, a)++-- | Runs an 'IO' operation and reports how long it took. Useful for+-- ad-hoc benchmarking.+reportTime :: MonadIO m => String -> m a -> m a+reportTime name io = do+  (_, _, a) <- reportAndShowTime name io+  return a++-- | Converts time in seconds to a human friendly string.+showTime :: Double -> String+showTime t = printf "%.2f%s" val unit+  where+   unit :: String+   (val, unit)+        | t >= 1    = (t, "s")+        | t >= 1e-3 = (t * 1e3, "ms")+        | t >= 1e-6 = (t * 1e6, "us")+        | otherwise = (t * 1e9, "ns")++-- | Converts a number of bytes to a human-friendsly string.+showAllocs :: Int64 -> String+showAllocs = renderBytesString . fromIntegral++-- | Runs an 'IO' action and returns a triple of the time it consumed (in sec),+-- the number of bytes it allocated, and the result it returned.+timeIt :: MonadIO m => m a -> m (Double, Int64, a)+timeIt action = do+  t0 <- liftIO getTimePoint+  a0 <- liftIO getAllocationCounter+  ret <- action+  a1 <- liftIO getAllocationCounter+  t <- liftIO $ getElapsedTime t0+  return (toDiffSeconds t, a0 - a1, ret)++-- | Runs an 'IO' action, reduces the result to normal form and returns a pair+-- of the time it consumed and the result it returned.+timeNF :: NFData a => IO a -> IO (Double, Int64, a)+timeNF action = timeIt $ evaluate . force =<< action++-- | Records the time to run an action excluding GC time.  Probably+-- more expensive than 'timeIt'.+timeItNoGC :: IO a -> IO (Double, Int64, a)+timeItNoGC io = do+  t0 <- getRTSStats+  a0 <- getAllocationCounter+  ret <- io+  a1 <- getAllocationCounter+  t1 <- getRTSStats+  let diff_ns = mutator_elapsed_ns t1 - mutator_elapsed_ns t0+  return (fromIntegral diff_ns / 1000000000, a0 - a1, ret)
+ Util/ToExp.hs view
@@ -0,0 +1,167 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE CPP #-}+module Util.ToExp+  ( ToExp(..)+  , intE+  , fracE+  , con+  , recConstr+  , fun+  , (=.=)+  , (=.==)+  , (=.=?)+  , (=$=)+  , (=$==)+  , pp+  , ppShow+  ) where++import qualified Data.Aeson as A+import qualified Data.ByteString.Char8 as BS+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Int+import Data.Scientific+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import qualified Data.Vector.Storable as SVector+import Language.Haskell.Exts hiding (intE)+#if MIN_VERSION_aeson(2,0,0)+import Util.Aeson+#endif+import Util.Text++infixl 1 =.=+infixl 1 =.==+infixl 1 =.=?+infixl 2 =$=+infixl 2 =$==++intE :: Integer -> Exp ()+intE n = (if n < 0 then paren else id) $+           Lit () (Int () n (show n))++fracE :: Rational -> Exp ()+fracE n = (if n < 0 then paren else id) $+            Lit () (Frac () n (show n))++con :: String -> Exp ()+con = Con () . UnQual () . name++recConstr :: String -> [FieldUpdate ()] -> Exp ()+recConstr recname = RecConstr () (UnQual () $ name recname)++fun :: String -> Exp ()+fun = function++-- | Function used to generate FieldUpdate for record constructors.+(=.=) :: ToExp a => String -> a -> FieldUpdate ()+field =.= value = FieldUpdate () (UnQual () $ name field) (toExp value)++(=.==) :: String -> Exp () -> FieldUpdate ()+(=.==) = (=.=)++(=.=?) :: String -> Maybe (Exp ()) -> FieldUpdate ()+(=.=?) = (=.=)++(=$=) :: ToExp a => Exp () -> a -> Exp ()+f =$= x = app f (toExp x)++(=$==) :: Exp () -> Exp () -> Exp ()+(=$==) = (=$=)++class ToExp a where+  toExp :: a -> Exp ()++instance ToExp (Exp ()) where+  toExp = id++instance ToExp () where+  toExp () = tuple []++instance ToExp Bool where+  toExp = con . show++instance ToExp Int where+  toExp = intE . fromIntegral++instance ToExp Double where+  toExp = fracE . realToFrac++instance ToExp Text where+  toExp = strE . Text.unpack++instance ToExp TextAndByteString where+  toExp s = fun "mkTextAndByteString" =$= toByteString s++instance ToExp BS.ByteString where+  toExp = strE . BS.unpack++instance (ToExp a, ToExp b) => ToExp (a, b) where+  toExp (a, b) = tuple [toExp a, toExp b]++instance ToExp a => ToExp (Maybe a) where+  toExp = maybe (con "Nothing") (con "Just" =$=)++instance ToExp a => ToExp [a] where+  toExp = listE . map toExp++instance ToExp Int64 where+  toExp = intE . fromIntegral++instance ToExp Char where+  toExp = charE+++instance ToExp a => ToExp (Vector.Vector a) where+  toExp v = fun "Vector.fromList" =$= Vector.toList v++instance (SVector.Storable a, ToExp a)+    => ToExp (SVector.Vector a) where+  toExp v = fun "SVector.fromList" =$= SVector.toList v++#if MIN_VERSION_aeson(2,0,0)+instance ToExp A.Key where+  toExp k = fun "fromText" =$= toExp (keyToText k)++instance ToExp v => ToExp (KeyMap v) where+  toExp m = fun "fromList" =$= objectToList m+#endif++instance (ToExp k, ToExp v) => ToExp (HashMap k v) where+  toExp m = fun "HashMap.fromList" =$= HashMap.toList m++instance ToExp A.Value where+  toExp A.Null = con "Null"+  toExp (A.Bool b) = con "Bool" =$= b+  toExp (A.Number n) = con "Number" =$==+    either toExp toExp (floatingOrInteger n :: Either Double Int)+  toExp (A.String s) = con "String" =$= s+  toExp (A.Array a) = con "Array" =$= a+  toExp (A.Object o) = con "Object" =$= o++-- TODO(t16157798): remove the OneLineMode; currently dumpCacheAsHaskellFn+-- depends on the output being a single line only+pp :: ToExp a => a -> String+pp x = prettyPrintStyleMode oneline defaultMode $ (noLoc <$ toExp x)+  where+  oneline = Style{ mode = OneLineMode, lineLength = 0, ribbonsPerLine = 0 }++-- To define a Show instance based on ToExp, use ppShow instead of pp;+-- the correct definition would define showsPrec and depending on the+-- operator precedence of the enclosing context and on the precedence inside+-- the expression would choose to parenthesize it or not.+-- YOLO. Let's just always parenthesize to be on the safe side.+--+-- > instance Show Foo where+-- >  show = ppShow+ppShow :: ToExp a => a -> String+ppShow x = pp $ paren (toExp x)
+ Util/Typeable.hs view
@@ -0,0 +1,24 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.Typeable+  ( cast1+  ) where++import Data.Maybe+import Data.Typeable+import Unsafe.Coerce++-- | A simpler variant of Data.Typeable.gcast1+{-# INLINE cast1 #-}+cast1 :: (Typeable t, Typeable t') => t a -> Maybe (t' a)+cast1 x = r+  where+    r = if typeOf1 x == typeOf1 (fromJust r)+      then Just $ unsafeCoerce x+      else Nothing
+ Util/WBVar.hs view
@@ -0,0 +1,137 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Util.WBVar (+  WBVar,+  newWBVar, newWBVarIO,+  readWBVar, writeWBVar, modifyWBVar', dirtyWBVar,+  writeBackWBVar,+  WBMVar,+  newEmptyWBMVar,+  newWBMVar,+  readWBMVar,+  takeWBMVar,+  writeWBMVar,+  withWBMVar,+  modifyWBMVar,+) where++import Util.Defer++import Control.Concurrent (forkIO)+import Control.Concurrent.STM+import Control.Exception++data WBVar a = WBVar+  { wbValue :: TVar a+  , wbDirty :: TVar Bool+  , wbWriting :: TVar Bool+  , wbWriteBack :: a -> IO ()+  }++newWBVar :: a -> (a -> IO ()) -> STM (WBVar a)+newWBVar x wb = WBVar+  <$> newTVar x+  <*> newTVar False+  <*> newTVar False+  <*> pure wb++newWBVarIO :: a -> (a -> IO ()) -> IO (WBVar a)+newWBVarIO x wb = WBVar+  <$> newTVarIO x+  <*> newTVarIO False+  <*> newTVarIO False+  <*> pure wb++readWBVar :: WBVar a -> STM a+readWBVar = readTVar . wbValue++writeWBVar :: WBVar a -> a -> Defer IO STM ()+writeWBVar v x = do+  lift $ writeTVar (wbValue v) x+  dirtyWBVar v++modifyWBVar' :: WBVar a -> (a -> a) -> Defer IO STM ()+modifyWBVar' v f = do+  lift $ modifyTVar' (wbValue v) f+  dirtyWBVar v++dirtyWBVar :: WBVar a -> Defer IO STM ()+dirtyWBVar v = do+  lift $ writeTVar (wbDirty v) True+  later $ writeBackWBVar v++-- Write back the variable if it is dirty.+--+-- NOTE: To avoid blocking an arbitrary number of threads, we'll keep writing+-- until the variable is no longer dirty. Suppose thread T1 is writing back+-- and T2 dirties the variable while this is happening and tries to write back+-- as well. In this situation, T2 will immediately return instead of blocking+-- until T1 is done. T1, on the other hand, will finish writing back, notice+-- that the variable is dirty and write back again.+writeBackWBVar :: WBVar a -> IO ()+writeBackWBVar v = do+  r <- atomically $ do+    dirty <- readTVar $ wbDirty v+    if dirty+      then do+        writing <- readTVar $ wbWriting v+        if writing+          then return Nothing+          else do+            writeTVar (wbDirty v) False+            writeTVar (wbWriting v) True+            Just <$> readTVar (wbValue v)+      else return Nothing+  case r of+    Just x -> do+      wbWriteBack v x+        `finally` atomically (writeTVar (wbWriting v) False)+        -- FIXME: A lame attempt to keep writing even in the case of an+        -- exception. I don't think this can really work without atomicity+        -- between the STM transaction and the write-back which seems impossible+        -- to achieve with STM.+        `onException` forkIO (writeBackWBVar v)+      writeBackWBVar v+    Nothing -> return ()+++-- | A 'WBVar' that can be empty/full like 'MVar'+type WBMVar a = WBVar (Maybe a)++newWBMVar :: a -> (a -> IO ()) -> STM (WBMVar a)+newWBMVar a f = newWBVar (Just a) (maybe (return ()) f)++newEmptyWBMVar :: (a -> IO ()) -> STM (WBMVar a)+newEmptyWBMVar f = newWBVar Nothing (maybe (return ()) f)++readWBMVar :: WBMVar a -> STM a+readWBMVar v = readWBVar v >>= maybe retry return++takeWBMVar :: WBMVar a -> IO a+takeWBMVar v = atomically $ do+  a <- readWBMVar v+  writeTVar (wbValue v) Nothing+  return a++writeWBMVar :: WBMVar a -> a -> Defer IO STM ()+writeWBMVar v = writeWBVar v . Just++withWBMVar :: WBMVar a -> (a -> IO b) -> IO b+withWBMVar v =+  bracket (takeWBMVar v) (atomically . writeTVar (wbValue v) . Just)+  -- omit the write-back, we know the value didn't change.++modifyWBMVar :: WBMVar a -> (a -> IO (a,b)) -> IO b+modifyWBMVar v f =+  mask $ \restore -> do+    a <- takeWBMVar v+    (a',b) <- restore (f a)+      `onException` atomically (writeTVar (wbValue v) (Just a))+    immediately $ writeWBMVar v a'+    return b
+ cpp/Constructible.h view
@@ -0,0 +1,36 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++namespace {++// Constructs object on already allocated memory.+template <typename T>+void constructImpl(T* p) noexcept {+  new (p) T;+}++// This allocates memory, and then constructs object.+template <typename T>+T* newImpl() noexcept {+  return new T;+}++} // namespace++#ifndef HS_DEFINE_DEFAULT_CONSTRUCTIBLE+#define HS_DEFINE_DEFAULT_CONSTRUCTIBLE(Name, Type...)                     \+  static_assert(std::is_default_constructible_v<Type>);                    \+  extern "C" void constructible_constructDefault##Name(Type* p) noexcept { \+    constructImpl(p);                                                      \+  }                                                                        \+  extern "C" Type* constructible_newDefault##Name() noexcept {             \+    return newImpl<Type>();                                                \+  }+#endif
+ cpp/Destructible.h view
@@ -0,0 +1,35 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++namespace {++template <typename T>+void destructImpl(T* p) noexcept {+  if (p != nullptr) {+    p->~T();+  }+}++template <typename T>+void deleteImpl(T* p) noexcept {+  delete p;+}++} // namespace++#ifndef HS_DEFINE_DESTRUCTIBLE+#define HS_DEFINE_DESTRUCTIBLE(Name, Type...)                     \+  extern "C" void destructible_destruct##Name(Type* p) noexcept { \+    destructImpl(p);                                              \+  }                                                               \+  extern "C" void destructible_delete##Name(Type* p) noexcept {   \+    deleteImpl(p);                                                \+  }+#endif
+ cpp/EventBaseDataplane.cpp view
@@ -0,0 +1,41 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#include <memory>++#include <glog/logging.h>++#include <folly/executors/IOThreadPoolExecutor.h>++extern "C" folly::IOThreadPoolExecutor*+common_hs_eventbase_newExecutor() noexcept {+  return new folly::IOThreadPoolExecutor(+      sysconf(_SC_NPROCESSORS_ONLN),+      std::make_shared<folly::NamedThreadFactory>("HaskellIOThreadPool"));+}++extern "C" void common_hs_eventbase_destroyExecutor(+    folly::IOThreadPoolExecutor* ex) noexcept {+  DCHECK_NOTNULL(ex)->join();+  delete ex;+}++extern "C" folly::EventBase* common_hs_eventbase_getIOExecutorEventBase(+    folly::IOThreadPoolExecutor* io) noexcept {+  return DCHECK_NOTNULL(io)->getEventBase();+}++extern "C" folly::Executor* common_hs_eventbase_castIOExecutorToExecutor(+    folly::IOThreadPoolExecutor* io) noexcept {+  return static_cast<folly::Executor*>(io);+}++extern "C" folly::Executor* common_hs_eventbase_castEventBaseToExecutor(+    folly::EventBase* io) noexcept {+  return static_cast<folly::Executor*>(io);+}
+ cpp/Executor.cpp view
@@ -0,0 +1,24 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#include <folly/executors/GlobalExecutor.h>++extern "C" folly::Executor::KeepAlive<>*+common_hs_getGlobalCPUExecutor() noexcept {+  return new folly::Executor::KeepAlive<>(folly::getGlobalCPUExecutor());+}++extern "C" void common_hs_releaseGlobalCPUExecutor(+    folly::Executor::KeepAlive<>* e) noexcept {+  delete e;+}++extern "C" folly::Executor* common_hs_getExecutorFromKeepAlive(+    folly::Executor::KeepAlive<>* k) noexcept {+  return k->get();+}
+ cpp/HsOption.h view
@@ -0,0 +1,95 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++#include <folly/Optional.h>+#include <optional>++#include "cpp/HsStructDefines.h"+#include "cpp/Marshallable.h"++// HsOption -------------------------------------------------------------------++#define hsc_derive_hs_option_unsafe(cxx_name...)             \+  hsc_printf(                                                \+      "deriveHsOptionUnsafe \"%s\" %lu ",                    \+      #cxx_name,                                             \+      (unsigned long)sizeof(HsOption<hs_option::cxx_name>)); \+  hsc_printf("%lu", (unsigned long)alignof(HsOption<hs_option::cxx_name>));++#define HS_OPTION_H(Name, Type) \+  namespace hs_option {         \+  using Name = Type;            \+  }++#define HS_OPTION_CPP(Name, Type...)                                       \+  extern "C" void* option_newHsOption##Name(Type* v) noexcept {            \+    return new HsOption<Type>(std::move(*v));                              \+  }                                                                        \+  extern "C" void option_ctorHsOption##Name(void* ret, Type* v) noexcept { \+    new (ret) HsOption<Type>(std::move(*v));                               \+  }                                                                        \+  HS_DEFINE_MARSHALLABLE(HsOption##Name, FB_SINGLE_ARG(HsOption<Type>))++template <typename T>+HS_STRUCT HsOption {+  T* value = nullptr;+  std::optional<T> opt = std::nullopt;++ public:+  HsOption() {}++  /* implicit */ HsOption(T && value) : opt(std::move(value)) {+    update();+  }++  template <typename U>+  /* implicit */ HsOption(folly::Optional<U> && value) : opt(std::move(value)) {+    update();+  }++  template <typename U>+  /* implicit */ HsOption(std::optional<U> && value) : opt(std::move(value)) {+    update();+  }++  HsOption(const HsOption&) = delete;++  HsOption(HsOption && other) noexcept : opt(std::move(other.opt)) {+    update();+    other.opt = std::nullopt; // a moved optional doesn't empty the value+    other.update();+  }++  HsOption& operator=(const HsOption&) = delete;++  HsOption& operator=(HsOption&& other) noexcept {+    opt = std::move(other.opt);+    update();+    other.opt = std::nullopt; // a moved optional doesn't empty the value+    other.update();+    return *this;+  }++  std::optional<T> toStdOptional()&& {+    std::optional<T> res = std::move(opt);+    opt = std::nullopt;+    update();+    return res;+  }++ private:+  void update() {+    if (opt.has_value()) {+      value = &opt.value();+    } else {+      value = nullptr;+    }+  }+};
+ cpp/HsStdTuple.h view
@@ -0,0 +1,195 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++#include <glog/logging.h>+#include <cstdarg>+#include <tuple>++#include "cpp/Destructible.h"+#include "cpp/HsStructDefines.h"++namespace hs_std_tuple::detail {++template <typename T>+T move_one(va_list& args) {+  T* l = va_arg(args, T*);+  return std::move(*l);+}++template <typename... T>+std::tuple<T...> makeTuple(va_list& args) {+  return std::tuple<T...>{move_one<T>(args)...};+}++template <typename Tuple, typename T, size_t I>+void peek_one(Tuple* t, va_list& args) {+  T* l = va_arg(args, T*);++  if constexpr (std::is_nothrow_move_constructible_v<T>) {+    // First delete the default allocated memory+    l->~T();+    // Then in-place move initialize+    new (l) T(static_cast<T&&>(std::move(std::get<I>(*t))));+  } else {+    *l = std::move(std::get<I>(*t));+  }+}++template <typename... T, std::size_t... I>+void peekVals(std::tuple<T...>* t, va_list& args, std::index_sequence<I...>) {+  (peek_one<std::tuple<T...>, T, I>(t, args), ...);+}++} // namespace hs_std_tuple::detail++#define hsc_derive_hs_std_tuple_unsafe(cxx_name...)  \+  hsc_printf(                                        \+      "deriveHsStdTupleUnsafe \"%s\" %lu %lu ",      \+      #cxx_name,                                     \+      (unsigned long)sizeof(hs_std_tuple::cxx_name), \+      (unsigned long)alignof(hs_std_tuple::cxx_name));++#define HS_STD_TUPLE_H(Name, Types) \+  namespace hs_std_tuple {          \+  using Name = HsStdTuple<Types>;   \+  }++/**+ * `__VA_ARGS__` is no good when the types listed have a comma within them.+ * For example, `std::tuple<int, HsEither<int, HsString>>` breaks as+ * `__VA_ARGS__` would give us "int", then "HsEither<int", then "HsString" as+ * the expanded type list. We need to generate code for peeking and poking+ * tuples with the types splatted out in a flat-map. The only way this seemed+ * possible was to (ab)use `va_list` to avoid needing to actually list out the+ * types. Since all the types we're sending along are pointers we don't need to+ * worry about argument promotions.+ */+#define HS_STD_TUPLE_CPP(Name)                                       \+  HS_DEFINE_MARSHALLABLE(Name, hs_std_tuple::Name)                   \+                                                                     \+  extern "C" void std_tuple_poke_##Name(                             \+      hs_std_tuple::Name* ptr, const char* fmt, ...) {               \+    va_list args;                                                    \+    va_start(args, fmt);                                             \+    new (ptr) hs_std_tuple::Name(args);                              \+    va_end(args);                                                    \+  }                                                                  \+                                                                     \+  extern "C" void std_tuple_peek_##Name(                             \+      hs_std_tuple::Name* ptr, const char* fmt, ...) {               \+    va_list args;                                                    \+    va_start(args, fmt);                                             \+    hs_std_tuple::detail::peekVals(                                  \+        ptr->getTuplePtr(),                                          \+        args,                                                        \+        std::make_index_sequence<hs_std_tuple::Name::tuple_size>{}); \+    va_end(args);                                                    \+  }++/**+ * std::tuple<> isn't default constructible, which means we can't derive+ * `Marshallable` for any `std::tuple`. Since we do really want default+ * constructibility, create this intermediate representation that introduces+ * default constructibility with DCHECK support when misused.+ */+template <typename... Ts>+HS_STRUCT HsStdTuple {+  union U {+    char mem_block[sizeof(std::tuple<Ts...>)];+    std::tuple<Ts...> tup;++    U() : mem_block() {}+    ~U() {}+  };++  U data_;++  bool has_tuple_{false};++ public:+  HsStdTuple() : data_(), has_tuple_(false) {}++  explicit HsStdTuple(std::tuple<Ts...> && t) {+    new (&data_.tup) decltype(data_.tup){std::move(t)};+    has_tuple_ = true;+  }++  HsStdTuple(const HsStdTuple&) = delete;+  HsStdTuple& operator=(const HsStdTuple&) = delete;++  HsStdTuple(HsStdTuple && other) noexcept {+    construct(std::move(other));+  }++  HsStdTuple& operator=(HsStdTuple&& other) noexcept {+    if (this != &other) {+      destruct();+      construct(std::move(other));+    }+    return *this;+  }++  explicit HsStdTuple(va_list & args) {+    new (&data_.tup) decltype(data_.tup){+        hs_std_tuple::detail::makeTuple<Ts...>(args)};+    has_tuple_ = true;+  }++  ~HsStdTuple() {+    destruct();+  }++  std::tuple<Ts...>* getTuplePtr() {+    DCHECK(has_tuple_);+    return &data_.tup;+  }++  std::tuple<Ts...> toStdTuple()&& {+    return std::move(data_.tup);+  }++  template <+      typename T = HsStdTuple<Ts...>,+      typename = std::enable_if_t<std::tuple_size_v<T> == 2>>+  auto toStdPair()&& {+    return std::make_pair(+        std::move(std::get<0>(data_.tup)), std::move(std::get<1>(data_.tup)));+  }++  static constexpr auto tuple_size = std::tuple_size_v<std::tuple<Ts...>>;++ private:+  void construct(HsStdTuple<Ts...> && other) noexcept {+    DCHECK(this != &other);+    has_tuple_ = other.has_tuple_;+    if (has_tuple_) {+      new (&data_.tup) decltype(data_.tup){std::move(other.data_.tup)};+    } else {+      new (&data_.mem_block) decltype(data_.mem_block){+          std::move(*other.data_.mem_block)};+    }+  }++  void destruct() {+    if (has_tuple_) {+      data_.tup.~tuple();+      has_tuple_ = false;+    }+  }+};++namespace std {++template <typename... Ts>+struct tuple_size<HsStdTuple<Ts...>> {+  static constexpr size_t value = sizeof...(Ts);+};++} // namespace std
+ cpp/HsStdVariant.h view
@@ -0,0 +1,66 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++#include <boost/mp11.hpp>+#include <glog/logging.h>+#include <variant>++#include "cpp/Marshallable.h"++namespace hs_std_variant::detail {++template <typename V>+void std_variant_poke(void* var, void* val, uint32_t idx) {+  constexpr auto variant_size = std::variant_size_v<V>;+  DCHECK_NE(idx, 0);+  DCHECK_LT(idx, variant_size);+  boost::mp11::mp_with_index<variant_size>(idx, [&](auto tag) {+    using type = std::variant_alternative_t<tag, V>;+    auto& val_ = *reinterpret_cast<type*>(val);+    new (var) V{std::in_place_index<tag>, std::move(val_)};+  });+}++} // namespace hs_std_variant::detail++// ****************************************************************************++#define hsc_derive_hs_std_variant_unsafe(cxx_name...)   \+  hsc_printf(                                           \+      "deriveHsStdVariantUnsafe \"%s\" %lu ",           \+      #cxx_name,                                        \+      (unsigned long)sizeof(hs_std_variant::cxx_name)); \+  hsc_alignment(hs_std_variant::cxx_name);++#define HS_STD_VARIANT_H(Name, ...)                       \+  namespace hs_std_variant {                              \+  using Name = std::variant<std::monostate, __VA_ARGS__>; \+  }++#define HS_STD_VARIANT_CPP(Name)                                              \+  HS_PEEKABLE(hs_std_variant::Name);                                          \+  HS_DEFINE_MARSHALLABLE(Name, hs_std_variant::Name)                          \+                                                                              \+  extern "C" void* std_variant_peek##Name(void* var, int32_t* idx) noexcept { \+    constexpr auto variant_size = std::variant_size_v<hs_std_variant::Name>;  \+    auto& var_ = *reinterpret_cast<hs_std_variant::Name*>(var);               \+    *idx = var_.index();                                                      \+    DCHECK_GT(*idx, 0);                                                       \+    DCHECK_LT(*idx, variant_size);                                            \+    return boost::mp11::mp_with_index<variant_size>(*idx, [&](auto tag) {     \+      return reinterpret_cast<void*>(&std::get<tag>(var_));                   \+    });                                                                       \+  }                                                                           \+                                                                              \+  extern "C" void std_variant_poke##Name(                                     \+      void* variant, void* val, int32_t tag) noexcept {                       \+    hs_std_variant::detail::std_variant_poke<hs_std_variant::Name>(           \+        variant, val, tag);                                                   \+  }
+ cpp/HsStruct.cpp view
@@ -0,0 +1,329 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#include "cpp/HsStruct.h"++#include "cpp/Marshallable.h"++/*+ * HsJSON+ */++HsJSON::HsJSON(const folly::dynamic& value) {+  switch (value.type()) {+    case folly::dynamic::NULLT:+      type = Type::Null;+      break;+    case folly::dynamic::BOOL:+      type = Type::Bool;+      integral = value.asBool();+      break;+    case folly::dynamic::INT64:+      type = Type::Integral;+      integral = value.asInt();+      break;+    case folly::dynamic::DOUBLE:+      type = Type::Real;+      real = value.asDouble();+      break;+    case folly::dynamic::STRING:+      type = Type::String;+      new (&string) HsString(value.asString());+      break;+    case folly::dynamic::ARRAY:+      type = Type::Array;+      {+        std::vector<HsJSON> v;+        v.reserve(value.size());+        for (const folly::dynamic& i : value) {+          v.emplace_back(i);+        }+        new (&array) HsArray<HsJSON>(std::move(v));+      }+      break;+    case folly::dynamic::OBJECT:+      type = Type::Object;+      {+        std::vector<HsString> keys;+        std::vector<HsJSON> values;+        keys.reserve(value.size());+        values.reserve(value.size());+        for (const auto& i : value.items()) {+          keys.emplace_back(i.first.asString());+          values.emplace_back(i.second);+        }+        new (&object) HsObject<HsJSON>(std::move(keys), std::move(values));+      }+      break;+  }+}++folly::dynamic HsJSON::toDynamic() && {+  switch (type) {+    case Type::Null:+      return folly::dynamic();+    case Type::Bool:+      return folly::dynamic(static_cast<bool>(integral));+    case Type::Integral:+      return folly::dynamic(integral);+    case Type::Real:+      return folly::dynamic(real);+    case Type::String:+      return folly::dynamic(std::move(string).toStdString());+    case Type::Array: {+      auto res = folly::dynamic::array();+      auto end = std::make_move_iterator(array.end());+      for (auto itr = std::make_move_iterator(array.begin()); itr != end;+           itr++) {+        res.push_back(std::move(*itr).toDynamic());+      }+      return res;+    }+    case Type::Object: {+      folly::dynamic res = folly::dynamic::object;+      auto items = std::move(object).take_items();++      // Manual version of zipping 2 iterators together+      auto key_itr = std::make_move_iterator(items.first.begin());+      auto key_end = std::make_move_iterator(items.first.end());+      auto val_itr = std::make_move_iterator(items.second.begin());+      auto val_end = std::make_move_iterator(items.second.end());++      while (key_itr != key_end && val_itr != val_end) {+        res.insert(+            std::move(*key_itr).toStdString(), std::move(*val_itr).toDynamic());+        key_itr++;+        val_itr++;+      }+      return res;+    }+  }+  folly::assume_unreachable();+}++void HsJSON::construct(HsJSON&& other) {+  DCHECK(this != &other);+  type = other.type;+  switch (type) {+    case Type::Null:+      break;+    case Type::Bool:+    case Type::Integral:+      integral = other.integral;+      break;+    case Type::Real:+      real = other.real;+      break;+    case Type::String:+      new (&string) HsString(std::move(other.string));+      break;+    case Type::Array:+      new (&array) HsArray<HsJSON>(std::move(other.array));+      break;+    case Type::Object:+      new (&object) HsObject<HsJSON>(std::move(other.object));+      break;+  }+}++void HsJSON::destruct() {+  if (type == Type::String) {+    string.~HsString();+  } else if (type == Type::Array) {+    array.~HsArray();+  } else if (type == Type::Object) {+    object.~HsMap();+  }+}++void ctorHsJSONNull(HsJSON* p) noexcept {+  new (p) HsJSON();+}++void ctorHsJSONBool(HsJSON* p, bool b) noexcept {+  new (p) HsJSON(b);+}++void ctorHsJSONInt(HsJSON* p, int64_t i) noexcept {+  new (p) HsJSON(i);+}++void ctorHsJSONDouble(HsJSON* p, double d) noexcept {+  new (p) HsJSON(d);+}++void ctorHsJSONString(HsJSON* p, HsString* txt) noexcept {+  new (p) HsJSON(std::move(*txt));+}++void ctorHsJSONArray(HsJSON* p, HsArray<HsJSON>* a) noexcept {+  new (p) HsJSON(std::move(*a));+}++void ctorHsJSONObject(HsJSON* p, HsObject<HsJSON>* o) noexcept {+  new (p) HsJSON(std::move(*o));+}++/*+ * HsObject+ */+extern "C" void common_hs_ctorHsObjectJSON(+    HsObject<HsJSON>* p,+    HsArray<HsString>* keys,+    HsArray<HsJSON>* vals) {+  new (p) HsObject<HsJSON>(+      std::move(*keys).toStdVector(), std::move(*vals).toStdVector());+}++/*+ * HsStringPiece+ */++HsStringPiece* newHsStringPiece(const char* p, size_t n) noexcept {+  return new HsStringPiece(p, n);+}++void ctorHsStringPiece(HsRange<char>* ret, const char* p, size_t n) noexcept {+  new (ret) HsStringPiece(p, n);+}++/*+ * HsString+ */++HsString* newHsString(const char* p, size_t n) noexcept {+  return new HsString(std::string(p, n));+}++void ctorHsString(HsString* ret, const char* p, size_t n) noexcept {+  new (ret) HsString(std::string(p, n));+}++/*+ * HsEither+ */++// HsEither<char,char> instead of HsEither<void,void> just to keep class+// definition happy.+void* newHsEither(HsEitherTag tag, void* val) {+  return new DummyHsEither(tag, val);+}++HS_DEFINE_MARSHALLABLE(HsMaybeInt, HsMaybe<int64_t>);+HS_DEFINE_MARSHALLABLE(HsMaybeDouble, HsMaybe<double>);+HS_DEFINE_MARSHALLABLE(HsMaybeString, HsMaybe<HsString>);++HS_DEFINE_MARSHALLABLE(HsEitherStringInt, HsEither<HsString, int64_t>);+HS_DEFINE_MARSHALLABLE(HsEitherStringDouble, HsEither<HsString, double>);+HS_DEFINE_MARSHALLABLE(HsEitherStringString, HsEither<HsString, HsString>);++HS_DEFINE_MARSHALLABLE(+    HsEitherStringArrayInt,+    HsEither<HsString, HsArray<int64_t>>);+HS_DEFINE_MARSHALLABLE(+    HsEitherStringArrayDouble,+    HsEither<HsString, HsArray<double>>);+HS_DEFINE_MARSHALLABLE(+    HsEitherStringArrayString,+    HsEither<HsString, HsArray<HsString>>);++HS_DEFINE_MARSHALLABLE(HsString, HsString);+HS_DEFINE_MARSHALLABLE(HsStringPiece, HsStringPiece);++HS_DEFINE_MARSHALLABLE(HsArrayInt16, HsArray<int16_t>);+HS_DEFINE_MARSHALLABLE(HsArrayInt32, HsArray<int32_t>);+HS_DEFINE_MARSHALLABLE(HsArrayInt64, HsArray<int64_t>);+HS_DEFINE_MARSHALLABLE(HsArrayUInt8, HsArray<uint8_t>);+HS_DEFINE_MARSHALLABLE(HsArrayUInt16, HsArray<uint16_t>);+HS_DEFINE_MARSHALLABLE(HsArrayUInt32, HsArray<uint32_t>);+HS_DEFINE_MARSHALLABLE(HsArrayUInt64, HsArray<uint64_t>);+HS_DEFINE_MARSHALLABLE(HsArrayFloat, HsArray<float>);+HS_DEFINE_MARSHALLABLE(HsArrayDouble, HsArray<double>);+HS_DEFINE_MARSHALLABLE(HsArrayString, HsArray<HsString>);+HS_DEFINE_MARSHALLABLE(HsArrayStringPiece, HsArray<HsStringPiece>);+HS_DEFINE_MARSHALLABLE(HsArrayJSON, HsArray<HsJSON>);++HS_DEFINE_MARSHALLABLE(HsSetInt16, HsSet<int16_t>);+HS_DEFINE_MARSHALLABLE(HsSetInt32, HsSet<int32_t>);+HS_DEFINE_MARSHALLABLE(HsSetInt64, HsSet<int64_t>);+HS_DEFINE_MARSHALLABLE(HsSetUInt8, HsSet<uint8_t>);+HS_DEFINE_MARSHALLABLE(HsSetUInt16, HsSet<uint16_t>);+HS_DEFINE_MARSHALLABLE(HsSetUInt32, HsSet<uint32_t>);+HS_DEFINE_MARSHALLABLE(HsSetUInt64, HsSet<uint64_t>);+HS_DEFINE_MARSHALLABLE(HsSetFloat, HsSet<float>);+HS_DEFINE_MARSHALLABLE(HsSetDouble, HsSet<double>);+HS_DEFINE_MARSHALLABLE(HsSetString, HsSet<HsString>);+HS_DEFINE_MARSHALLABLE(HsSetJSON, HsSet<HsJSON>);++HS_DEFINE_MARSHALLABLE(HsMapIntInt, HsMap<int64_t, int64_t>);+HS_DEFINE_MARSHALLABLE(HsMapUInt8UInt8, HsMap<uint8_t, uint8_t>);+HS_DEFINE_MARSHALLABLE(HsMapUInt16UInt16, HsMap<uint16_t, uint16_t>);+HS_DEFINE_MARSHALLABLE(HsMapInt32Int32, HsMap<int32_t, int32_t>);+HS_DEFINE_MARSHALLABLE(HsMapInt32Double, HsMap<int32_t, double>);+HS_DEFINE_MARSHALLABLE(HsMapIntDouble, HsMap<int64_t, double>);+HS_DEFINE_MARSHALLABLE(HsMapIntString, HsMap<int64_t, HsString>);+HS_DEFINE_MARSHALLABLE(HsMapInt32String, HsMap<int32_t, HsString>);+HS_DEFINE_MARSHALLABLE(HsMapDoubleInt32, HsMap<double, int32_t>);+HS_DEFINE_MARSHALLABLE(HsMapStringInt32, HsMap<HsString, int32_t>);+HS_DEFINE_MARSHALLABLE(HsMapStringInt, HsMap<HsString, int64_t>);+HS_DEFINE_MARSHALLABLE(HsMapStringDouble, HsMap<HsString, double>);+HS_DEFINE_MARSHALLABLE(HsMapStringString, HsMap<HsString, HsString>);++HS_DEFINE_MARSHALLABLE(HsObjectJSON, HsObject<HsJSON>);+HS_DEFINE_MARSHALLABLE(HsJSON, HsJSON);++HS_OPTION_CPP(Bool, bool);+HS_OPTION_CPP(UInt8, uint8_t);+HS_OPTION_CPP(Int16, int16_t);+HS_OPTION_CPP(Int32, int32_t);+HS_OPTION_CPP(Int64, int64_t);+HS_OPTION_CPP(UInt32, uint32_t);+HS_OPTION_CPP(UInt64, uint64_t);+HS_OPTION_CPP(Float, float);+HS_OPTION_CPP(Double, double);+HS_OPTION_CPP(String, HsString);+HS_OPTION_CPP(StringView, HsStringPiece);+HS_OPTION_CPP(HsJSON, HsJSON);++HS_DEFINE_ARRAY_CONSTRUCTIBLE(Int16, int16_t);+HS_DEFINE_ARRAY_CONSTRUCTIBLE(Int32, int32_t);+HS_DEFINE_ARRAY_CONSTRUCTIBLE(Int64, int64_t);+// std::vector<bool> doesn't guarantee contiguous memory layout,+// so use HsArray<uint8_t> to store one bool per byte+HS_DEFINE_ARRAY_CONSTRUCTIBLE(UInt8, uint8_t);+HS_DEFINE_ARRAY_CONSTRUCTIBLE(UInt16, uint16_t);+HS_DEFINE_ARRAY_CONSTRUCTIBLE(UInt32, uint32_t);+HS_DEFINE_ARRAY_CONSTRUCTIBLE(UInt64, uint64_t);+HS_DEFINE_ARRAY_CONSTRUCTIBLE(Float, float);+HS_DEFINE_ARRAY_CONSTRUCTIBLE(Double, double);+HS_DEFINE_ARRAY_CONSTRUCTIBLE(String, HsString);+HS_DEFINE_ARRAY_CONSTRUCTIBLE(StringView, HsStringPiece);+HS_DEFINE_ARRAY_CONSTRUCTIBLE(HsJSON, HsJSON);++HS_DEFINE_MAP_CONSTRUCTIBLE(IntInt, int64_t, int64_t);+HS_DEFINE_MAP_CONSTRUCTIBLE(UInt8UInt8, uint8_t, uint8_t);+HS_DEFINE_MAP_CONSTRUCTIBLE(UInt16UInt16, uint16_t, uint16_t);+HS_DEFINE_MAP_CONSTRUCTIBLE(Int32Int32, int32_t, int32_t);+HS_DEFINE_MAP_CONSTRUCTIBLE(Int32Double, int32_t, double);+HS_DEFINE_MAP_CONSTRUCTIBLE(Int32String, int32_t, HsString);+HS_DEFINE_MAP_CONSTRUCTIBLE(DoubleInt32, double, int32_t);+HS_DEFINE_MAP_CONSTRUCTIBLE(StringInt32, HsString, int32_t);+HS_DEFINE_MAP_CONSTRUCTIBLE(StringDouble, HsString, double);+HS_DEFINE_MAP_CONSTRUCTIBLE(StringString, HsString, HsString);++HS_DEFINE_SET_CONSTRUCTIBLE(Int16, int16_t);+HS_DEFINE_SET_CONSTRUCTIBLE(Int32, int32_t);+HS_DEFINE_SET_CONSTRUCTIBLE(Int64, int64_t);+HS_DEFINE_SET_CONSTRUCTIBLE(UInt8, uint8_t);+HS_DEFINE_SET_CONSTRUCTIBLE(UInt16, uint16_t);+HS_DEFINE_SET_CONSTRUCTIBLE(UInt32, uint32_t);+HS_DEFINE_SET_CONSTRUCTIBLE(UInt64, uint64_t);+HS_DEFINE_SET_CONSTRUCTIBLE(Float, float);+HS_DEFINE_SET_CONSTRUCTIBLE(Double, double);+HS_DEFINE_SET_CONSTRUCTIBLE(String, HsString);+HS_DEFINE_SET_CONSTRUCTIBLE(HsJSON, HsJSON);
+ cpp/HsStruct.h view
@@ -0,0 +1,1027 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++#include <glog/logging.h>+#include <cstddef>+#include <string_view>++#include <folly/Memory.h>+#include <folly/Optional.h>+#include <folly/Try.h>+#include <folly/json/dynamic.h>+#include <optional>++#include "cpp/HsOption.h"+#include "cpp/HsStdTuple.h"+#include "cpp/HsStdVariant.h"+#include "cpp/HsStructDefines.h"+#include "cpp/Marshallable.h"++#define HS_PEEKABLE(t)              \+  static_assert(                    \+      std::is_standard_layout_v<t>, \+      #t " is a standard-layout class so we can peek it")+#define HS_POKEABLE(t)                     \+  static_assert(                           \+      std::is_trivially_destructible_v<t>, \+      #t " is trivially destructible so we can poke it")++template <typename T>+HS_STRUCT HsRange {+  const T* a = nullptr;+  size_t n = 0;++ public:+  HsRange() {}++  /* implicit */ HsRange(folly::Range<const T*> s) : a(s.data()), n(s.size()) {}++  HsRange(const T* a, size_t n) : a(a), n(n) {}++  template <+      typename U = T,+      typename = typename std::enable_if<std::is_same<U, char>::value>::type>+  explicit HsRange(std::string_view sv) : a(sv.data()), n(sv.size()) {}++  const T* data() const {+    return a;+  }++  size_t size() const {+    return n;+  }++  /* implicit */ operator folly::Range<const T*>() const {+    return folly::Range<const T*>(a, n);+  }++  template <+      typename U = T,+      typename = typename std::enable_if<std::is_same<U, char>::value>::type>+  std::string_view toStdStringView() {+    return std::string_view(a, n);+  }+};++using HsStringPiece = HsRange<char>;++using DummyHsRange = HsRange<std::nullptr_t>;+HS_PEEKABLE(DummyHsRange);+HS_POKEABLE(DummyHsRange);+static_assert(+    sizeof(HsStringPiece) == sizeof(DummyHsRange),+    "HsStringPiece is of the same size as DummyHsRange");++template <typename T>+HS_STRUCT HsMaybe {+  const T* ptr = nullptr;++ public:+  HsMaybe() {}++  /* implicit */ HsMaybe(T && value) : ptr(new T(std::move(value))) {}++  /* implicit */ HsMaybe(std::unique_ptr<T> && value) : ptr(value.release()) {}++  template <typename U>+  /* implicit */ HsMaybe(folly::Optional<U> && value) {+    if (value.hasValue()) {+      ptr = new T(std::move(value).value());+    }+  }++  template <typename U>+  /* implicit */ HsMaybe(std::optional<U> && value) {+    if (value.has_value()) {+      ptr = new T(std::move(value).value());+    }+  }++  template <typename... Args>+  explicit HsMaybe(std::in_place_t, Args && ... args)+      : ptr(new T(std::forward<Args>(args)...)) {}++  HsMaybe(const HsMaybe&) = delete;++  HsMaybe(HsMaybe && other) noexcept : ptr(other.ptr) {+    other.ptr = nullptr;+  }++  HsMaybe& operator=(const HsMaybe&) = delete;++  HsMaybe& operator=(HsMaybe&& other) noexcept {+    if (this != &other) {+      delete ptr;+      ptr = other.ptr;+      other.ptr = nullptr;+    }+    return *this;+  }++  ~HsMaybe() {+    delete ptr;+  }++  bool hasValue() const {+    return ptr != nullptr;+  }++  const T& value() const {+    if (hasValue()) {+      return *ptr;+    } else {+      throw std::logic_error("HsMaybe does not have value");+    }+  }+};++using DummyHsMaybe = HsMaybe<std::nullptr_t>;+HS_PEEKABLE(DummyHsMaybe);+static_assert(+    sizeof(HsMaybe<HsStringPiece>) == sizeof(DummyHsMaybe),+    "HsMaybe<HsStringPiece> is of the same size as DummyHsMaybe");++/*+ * Generic HsEither implementation.+ */++enum HsEitherTag { HS_LEFT, HS_RIGHT };++enum HsLeftTag { HsLeft };++enum HsRightTag { HsRight };++template <typename L, typename R>+HS_STRUCT HsEither {+  bool isLeft;+  union {+    L* left;+    R* right;+  };+  friend void* newHsEither(HsEitherTag, void*);++ public:+  template <typename... Args>+  explicit HsEither(HsLeftTag, Args && ... args)+      : isLeft(true), left(new L(std::forward<Args>(args)...)) {}++  template <typename... Args>+  explicit HsEither(HsRightTag, Args && ... args)+      : isLeft(false), right(new R(std::forward<Args>(args)...)) {}++  template <typename... Args>+  HsEither() {+    static_assert(std::is_default_constructible_v<L>);+    isLeft = true;+    left = new L;+  }++  template <typename T>+  /* implicit */ HsEither(folly::Try<T> && value)+      : isLeft(value.hasException()) {+    if (isLeft) {+      left = new L(std::move(value).exception());+    } else {+      right = new R(std::move(value).value());+    }+  }++  HsEither(const HsEither&) = delete;++  HsEither(HsEither && other) noexcept {+    construct(std::move(other));+  }++  HsEither& operator=(const HsEither&) = delete;++  HsEither& operator=(HsEither&& other) noexcept {+    if (this != &other) {+      destruct();+      construct(std::move(other));+    }+    return *this;+  }++  ~HsEither() {+    destruct();+  }++ private:+  void construct(HsEither<L, R> && other) noexcept {+    DCHECK(this != &other);+    isLeft = other.isLeft;+    if (isLeft) {+      left = new L(std::move(*other.left));+    } else {+      right = new R(std::move(*other.right));+    }+  }++  void destruct() {+    if (isLeft) {+      delete left;+    } else {+      delete right;+    }+  }++  explicit HsEither(HsEitherTag tag, void* val) {+    switch (tag) {+      case HS_LEFT:+        isLeft = true;+        left = static_cast<L*>(val);+        break;+      case HS_RIGHT:+        isLeft = false;+        left = static_cast<R*>(val);+        break;+      default:+        __builtin_unreachable();+    }+  }++ public:+  bool hasLeft() const {+    return isLeft;+  }++  bool hasRight() const {+    return !isLeft;+  }++  const L& getLeft() const {+    if (hasLeft()) {+      return *left;+    } else {+      throw std::logic_error("HsEither does not have left");+    }+  }++  const R& getRight() const {+    if (hasRight()) {+      return *right;+    } else {+      throw std::logic_error("HsEither does not have right");+    }+  }+};++using DummyHsEither = HsEither<std::nullptr_t, std::nullptr_t>;+HS_PEEKABLE(DummyHsEither);+static_assert(+    sizeof(HsEither<HsStringPiece, int64_t>) == sizeof(DummyHsEither),+    "HsEither<HsStringPiece, int64_t> is of the same size as DummyHsEither");++extern void* newHsEither(HsEitherTag, void*);++/*+ * A generic HsPair implementation, which stores pointers to the first and+ * second elements of the pair. This indirection causes poor performance, so+ * if you're using it for e.g. complex pairs "((a,b),(c,d))" or in hot code+ * path - you probably want to spin your own pair implementation with+ * concrete types, like:+ *+ * HS_STRUCT HsPairXY {+ *   X x;+ *   Y y;+ * }+ *+ * For simple cases, this should be fine.+ */+template <typename F, typename S>+HS_STRUCT HsPair {+  F* fst_;+  S* snd_;++ public:+  template <typename U, typename V>+  /* implicit */ HsPair(std::pair<U, V> && pair)+      : fst_(new F(std::move(pair.first))),+        snd_(new S(std::move(pair.second))) {}++  /* implicit */ HsPair(F && f, S && s)+      : fst_(new F(std::move(f))), snd_(new S(std::move(s))) {}++  HsPair(const HsPair&) = delete;++  HsPair(HsPair && other) noexcept+      : fst_(new F(std::move(*other.fst_))),+        snd_(new S(std::move(*other.snd_))) {}++  HsPair& operator=(const HsPair&) = delete;++  HsPair& operator=(HsPair&& other) noexcept {+    *fst_ = std::move(*other.fst_);+    *snd_ = std::move(*other.snd_);+  }++  ~HsPair() {+    delete fst_;+    delete snd_;+  }++  const F& first() const {+    return *fst_;+  }++  const S& second() const {+    return *snd_;+  }+};++using DummyHsPair = HsPair<std::nullptr_t, std::nullptr_t>;+HS_PEEKABLE(DummyHsPair);+static_assert(+    sizeof(HsPair<HsStringPiece, int64_t>) == sizeof(DummyHsPair),+    "HsPair<HsStringPiece, int64_t> is of the same size as DummyHsPair");++HS_STRUCT HsString {+  std::string s_;+  const char* str = s_.data();+  size_t len = s_.size();++ public:+  HsString() {}++  /* implicit */ HsString(std::string s) : s_(std::move(s)) {}++  explicit HsString(const folly::exception_wrapper& e)+      : s_(e.what().toStdString()) {}++  HsString(const HsString& other) noexcept : s_(other.s_) {}++  HsString(HsString && other) noexcept : s_(std::move(other.s_)) {}++  HsString& operator=(const HsString& other) noexcept {+    if (this != &other) {+      s_ = other.s_;+      update();+    }+    return *this;+  }++  HsString& operator=(HsString&& other) noexcept {+    if (this != &other) {+      s_ = std::move(other.s_);+      update();+    }+    return *this;+  }++  HsString& operator=(std::string&& other) noexcept {+    if (&(this->s_) != &other) {+      s_ = std::move(other);+      update();+    }+    return *this;+  }++ private:+  void update() {+    str = s_.data();+    len = s_.size();+  }++ public:+  const std::string& getStr() const {+    return s_;+  }++  size_t size() const {+    return s_.size();+  }++  const char* data() const {+    return s_.data();+  }++  char* mutable_data() {+    update();+    return const_cast<char*>(s_.data());+  }++  void resize(size_t capacity) {+    s_.resize(capacity);+    update();+  }++  void clear() {+    s_.clear();+    update();+  }++  void append(const char* src, int n) {+    s_.append(src, n);+    update();+  }++  void append(const HsString& src) {+    s_.append(src.s_);+    update();+  }++  std::string toStdString()&& {+    std::string res(std::move(s_));+    update();+    return res;+  }+};++inline bool operator<(const HsString& lhs, const HsString& rhs) {+  return lhs.getStr() < rhs.getStr();+}++HS_PEEKABLE(HsString);++template <typename T>+HS_STRUCT HsArray {+  static_assert(!std::is_same_v<T, bool>, "Use HsArray<uint8_t> instead");+  std::vector<T> v_;+  const T* a = v_.data();+  size_t n = v_.size();++ public:+  HsArray() {}++  /* implicit */ HsArray(std::vector<T> && v) : v_(std::move(v)) {}++  template <typename InputIterator>+  HsArray(InputIterator first, InputIterator last) : v_(first, last) {}++  template <typename Container>+  HsArray(Container && c)+      : v_(std::make_move_iterator(c.begin()),+           std::make_move_iterator(c.end())) {}++  HsArray(std::initializer_list<T> init) : v_(init) {}++  HsArray(const HsArray& other) : v_(other.v_) {}++  HsArray(HsArray && other) noexcept : v_(std::move(other.v_)) {}++  HsArray& operator=(const HsArray& other) {+    if (this != other) {+      v_ = other.v_;+      update();+    }+    return *this;+  }++  HsArray& operator=(HsArray&& other) noexcept {+    if (this != &other) {+      v_ = std::move(other.v_);+      update();+    }+    return *this;+  }++ private:+  void update() {+    a = v_.data();+    n = v_.size();+  }++ public:+  using Iterator = typename std::vector<T>::iterator;+  using ConstIterator = typename std::vector<T>::const_iterator;++  void reserve(size_t capacity) {+    v_.reserve(capacity);+    update();+  }++  void clear() {+    v_.clear();+    update();+  }++  Iterator begin() {+    return v_.begin();+  }++  Iterator end() {+    return v_.end();+  }++  ConstIterator begin() const {+    return v_.begin();+  }++  ConstIterator end() const {+    return v_.end();+  }++  template <typename... Args>+  void add(Args && ... args) {+    v_.emplace_back(std::forward<Args>(args)...);+    update();+  }++  T& operator[](size_t index) {+    return v_[index];+  }++  const T& operator[](size_t index) const {+    return v_[index];+  }++  size_t size() const {+    return v_.size();+  }++  std::vector<T> toStdVector()&& {+    auto res = std::move(v_);+    clear();+    return res;+  }+};++using DummyHsArray = HsArray<std::nullptr_t>;+HS_PEEKABLE(DummyHsArray);+static_assert(+    sizeof(HsArray<HsString>) == sizeof(DummyHsArray),+    "HsArray<HsString> is of the same size as DummyHsArray");+static_assert(sizeof(HsArray<uint8_t>) == sizeof(DummyHsArray));++#define HS_DEFINE_ARRAY_CONSTRUCTIBLE(Name, Type)                          \+  extern "C" HsArray<Type>* vector_newHsArray##Name(size_t len) {          \+    auto arr = new HsArray<Type>();                                        \+    arr->reserve(len);                                                     \+    return arr;                                                            \+  }                                                                        \+                                                                           \+  extern "C" void vector_constructHsArray##Name(                           \+      HsArray<Type>* arr, size_t len) {                                    \+    new (arr) HsArray<Type>();                                             \+    arr->reserve(len);                                                     \+  }                                                                        \+                                                                           \+  extern "C" void vector_addHsArray##Name(HsArray<Type>* arr, Type* val) { \+    arr->add(std::move(*val));                                             \+  }++template <typename Key>+HS_STRUCT HsSet {+  std::vector<Key> k_;+  const Key* keys = k_.data();+  size_t n = k_.size();++ public:+  HsSet() {}++  /* implicit */ HsSet(std::vector<Key> && k) : k_(std::move(k)) {}++  /* implicit */ HsSet(std::unordered_set<Key> && s) {+    std::vector<Key> k;+    k.reserve(s.size());+    while (!s.empty()) {+      auto nh = s.extract(s.begin());+      k.insert(std::move(nh.value()));+    }+    this->k_ = k;+    update();+  }++  template <typename InputIterator>+  /* implicit */ HsSet(InputIterator first, InputIterator last) {+    reserve(std::distance(first, last));+    for (auto it = first; it != last; ++it) {+      auto val = *it;+      add(std::move(val));+    }+    update();+  }++  template <typename Container>+  /* implicit */ HsSet(Container && c)+      : HsSet(+            std::make_move_iterator(c.begin()),+            std::make_move_iterator(c.end())) {}++  /* implicit */ HsSet(std::initializer_list<Key> init)+      : HsSet(init.begin(), init.end()) {}++  HsSet(const HsSet&) = delete;++  HsSet(HsSet && other) noexcept : k_(std::move(other.k_)) {+    update();+  }++  HsSet& operator=(const HsSet&) = delete;++  HsSet& operator=(HsSet&& other) noexcept {+    if (this != &other) {+      k_ = std::move(other.k_);+      update();+    }++    return *this;+  }++ private:+  void update() {+    keys = k_.data();+    n = k_.size();+  }++ public:+  struct ConstIterator {+    const HsSet& object;+    size_t index = 0;++    explicit ConstIterator(const HsSet& object) : object(object) {}++    bool isValid() const {+      return index < object.n;+    }++    void next() {+      ++index;+    }++    const Key& get() const {+      DCHECK(isValid());+      return object.keys[index];+    }++    ConstIterator getIterator() const {+      return ConstIterator(*this);+    }+  };++  void reserve(size_t capacity) {+    k_.reserve(capacity);+    update();+  }++  void clear() {+    k_.clear();+    update();+  }++  std::vector<Key> toStdVector()&& {+    auto res = std::move(k_);+    update();+    return res;+  }++  std::unordered_set<Key> toStdUnorderedSet()&& {+    auto k = std::move(k_);+    std::unordered_set<Key> res(+        std::make_move_iterator(k.begin()), std::make_move_iterator(k.end()));+    update();+    return res;+  }++  template <typename Arg>+  void add(Arg && arg) {+    k_.emplace_back(std::forward<Arg>(arg));+    update();+  }+};++using DummyHsSet = HsSet<std::nullptr_t>;+HS_PEEKABLE(DummyHsSet);+static_assert(+    sizeof(HsSet<HsString>) == sizeof(DummyHsSet),+    "HsSet<HsString> is of the same size as DummyHsSet");+static_assert(sizeof(HsSet<uint8_t>) == sizeof(DummyHsSet));++#define HS_DEFINE_SET_CONSTRUCTIBLE(Name, Type)                            \+  extern "C" void set_constructHsSet##Name(HsSet<Type>* set, size_t len) { \+    new (set) HsSet<Type>();                                               \+    set->reserve(len);                                                     \+  }                                                                        \+                                                                           \+  extern "C" void set_addHsSet##Name(HsSet<Type>* set, Type* val) {        \+    set->add(std::move(*val));                                             \+  }++template <typename Key, typename Value>+HS_STRUCT HsMap {+  std::vector<Key> k_;+  std::vector<Value> v_;+  const Key* keys = k_.data();+  const Value* values = v_.data();+  size_t n = k_.size();++ public:+  HsMap() {}++  HsMap(std::vector<Key> && k, std::vector<Value> && v)+      : k_(std::move(k)), v_(std::move(v)) {+    DCHECK(k_.size() == v_.size());+  }++  template <typename InputIterator>+  HsMap(InputIterator first, InputIterator last) {+    reserve(std::distance(first, last));+    for (auto it = first; it != last; ++it) {+      // when `it` is a `move_iterator`, the content will be moved;+      // otherwise, the content will be copied.+      auto value = *it;+      add(std::move(value.first), std::move(value.second));+    }+  }++  template <typename Container>+  HsMap(Container && c)+      : HsMap(+            std::make_move_iterator(c.begin()),+            std::make_move_iterator(c.end())) {}++  HsMap(std::initializer_list<std::pair<const Key, Value>> init)+      : HsMap(init.begin(), init.end()) {}++  HsMap(const HsMap&) = delete;++  HsMap(HsMap && other) noexcept+      : k_(std::move(other.k_)), v_(std::move(other.v_)) {}++  HsMap& operator=(const HsMap&) = delete;++  HsMap& operator=(HsMap&& other) noexcept {+    if (this != &other) {+      k_ = std::move(other.k_);+      v_ = std::move(other.v_);+      update();+    }+    return *this;+  }++ private:+  void update() {+    DCHECK(k_.size() == v_.size());+    keys = k_.data();+    values = v_.data();+    n = k_.size();+  }++ public:+  struct ConstIterator {+    const HsMap& object;+    size_t index = 0;++    explicit ConstIterator(const HsMap& object) : object(object) {}++    bool isValid() const {+      return index < object.n;+    }++    void next() {+      ++index;+    }++    const Key& getKey() const {+      DCHECK(isValid());+      return object.keys[index];+    }++    const Value& getValue() const {+      DCHECK(isValid());+      return object.values[index];+    }+  };++  ConstIterator getIterator() const {+    return ConstIterator(*this);+  }++  void reserve(size_t capacity) {+    k_.reserve(capacity);+    v_.reserve(capacity);+    update();+  }++  void clear() {+    k_.clear();+    v_.clear();+    update();+  }++  std::pair<std::vector<Key>, std::vector<Value>> take_items()&& {+    auto res = std::make_pair(std::move(k_), std::move(v_));+    update();+    return res;+  }++  template <typename Arg, typename... Args>+  void add(Arg && arg, Args && ... args) {+    k_.emplace_back(std::forward<Arg>(arg));+    try {+      v_.emplace_back(std::forward<Args>(args)...);+    } catch (...) {+      k_.pop_back();+      throw;+    }+    update();+  }++  // This is a linear lookup which is supposed to be used when you only want+  // to marshal a single entry of the whole map (e.g. in fbobjAttr).+  const Value* getPtr(const Key& key) const {+    // The last mapping overrides the previous ones+    for (int i = static_cast<int>(k_.size()) - 1; i >= 0; --i) {+      if (k_[i] == key) {+        return &v_[i];+      }+    }+    return nullptr;+  }++  template <typename T>+  typename std::enable_if<+      std::is_same<Key, HsString>::value &&+          std::is_convertible<T, folly::StringPiece>::value,+      const Value*>::type+  getPtr(const T& key) const {+    // The last mapping overrides the previous ones+    for (int i = static_cast<int>(k_.size()) - 1; i >= 0; --i) {+      if (folly::StringPiece(k_[i].getStr()) == key) {+        return &v_[i];+      }+    }+    return nullptr;+  }+};++#define HS_DEFINE_MAP_CONSTRUCTIBLE(Name, KeyType, ValType)       \+  extern "C" void map_constructHsMap##Name(                       \+      HsMap<KeyType, ValType>* map, size_t len) {                 \+    new (map) HsMap<KeyType, ValType>();                          \+    map->reserve(len);                                            \+  }                                                               \+  extern "C" void map_addHsMap##Name(                             \+      HsMap<KeyType, ValType>* map, KeyType* key, ValType* val) { \+    map->add(std::move(*key), std::move(*val));                   \+  }++template <typename T>+using HsIntMap = HsMap<int64_t, T>;+using DummyHsIntMap = HsIntMap<std::nullptr_t>;+HS_PEEKABLE(DummyHsIntMap);++template <typename T>+using HsObject = HsMap<HsString, T>;+using DummyHsObject = HsObject<std::nullptr_t>;+HS_PEEKABLE(DummyHsObject);++static_assert(+    sizeof(HsIntMap<HsString>) == sizeof(DummyHsIntMap) &&+        sizeof(HsObject<HsString>) == sizeof(DummyHsObject) &&+        sizeof(DummyHsIntMap) == sizeof(DummyHsObject),+    "All HsMap<Key, Value> must have the same size");++class HsJSON {+ public:+  enum class Type {+    Null,+    Bool,+    Integral,+    Real,+    String,+    Array,+    Object,+  };++#ifdef __HSC2HS__+ public:+#else+ private:+#endif++  Type type;+  union {+    std::nullptr_t data;+    int64_t integral;+    double real;+    HsString string;+    HsArray<HsJSON> array;+    HsObject<HsJSON> object;+  };++ public:+  /* implicit */ HsJSON() : type(Type::Null) {}++  /* implicit */ HsJSON(bool value) : type(Type::Bool), integral(value) {}++  /* implicit */ HsJSON(int64_t value)+      : type(Type::Integral), integral(value) {}++  /* implicit */ HsJSON(double value) : type(Type::Real), real(value) {}++  /* implicit */ HsJSON(HsString&& value)+      : type(Type::String), string(std::move(value)) {}++  /* implicit */ HsJSON(HsArray<HsJSON>&& value)+      : type(Type::Array), array(std::move(value)) {}++  /* implicit */ HsJSON(HsObject<HsJSON>&& value)+      : type(Type::Object), object(std::move(value)) {}++  /* implicit */ HsJSON(const folly::dynamic& value);++  HsJSON(const HsJSON&) = delete;++  HsJSON(HsJSON&& other) noexcept {+    construct(std::move(other));+  }++  HsJSON& operator=(const HsJSON&) = delete;++  HsJSON& operator=(HsJSON&& other) noexcept {+    if (this != &other) {+      destruct();+      construct(std::move(other));+    }+    return *this;+  }++  ~HsJSON() {+    destruct();+  }++ private:+  void construct(HsJSON&& other);++  void destruct();++ public:+  Type getType() const {+    return type;+  }++  int64_t asIntegral() const {+    DCHECK(type == Type::Bool || type == Type::Integral);+    return integral;+  }++  int64_t& asIntegral() {+    DCHECK(type == Type::Bool || type == Type::Integral);+    return integral;+  }++  double asReal() const {+    DCHECK(type == Type::Real);+    return real;+  }++  double& asReal() {+    DCHECK(type == Type::Real);+    return real;+  }++  const HsString& asString() const {+    DCHECK(type == Type::String);+    return string;+  }++  HsString& asString() {+    DCHECK(type == Type::String);+    return string;+  }++  const HsArray<HsJSON>& asArray() const {+    DCHECK(type == Type::Array);+    return array;+  }++  HsArray<HsJSON>& asArray() {+    DCHECK(type == Type::Array);+    return array;+  }++  const HsObject<HsJSON>& asObject() const {+    DCHECK(type == Type::Object);+    return object;+  }++  HsObject<HsJSON>& asObject() {+    DCHECK(type == Type::Object);+    return object;+  }++  folly::dynamic toDynamic() &&;+};++HS_PEEKABLE(HsJSON);++HS_OPTION_H(Bool, bool)+HS_OPTION_H(UInt8, uint8_t)+HS_OPTION_H(Int16, int16_t)+HS_OPTION_H(Int32, int32_t)+HS_OPTION_H(Int64, int64_t)+HS_OPTION_H(UInt32, uint32_t)+HS_OPTION_H(UInt64, uint64_t)+HS_OPTION_H(Float, float)+HS_OPTION_H(Double, double)+HS_OPTION_H(String, HsString)+HS_OPTION_H(StringView, HsStringPiece)+HS_OPTION_H(HsJSON, HsJSON)
+ cpp/HsStructDefines.h view
@@ -0,0 +1,15 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++#ifdef __HSC2HS__+#define HS_STRUCT struct+#else+#define HS_STRUCT class+#endif
+ cpp/HsVariant.h view
@@ -0,0 +1,343 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++#include "cpp/HsStruct.h"++#include <utility>+#include <vector>++struct HsVariant {+  using VariantType = HsJSON;+  using MapType = HsObject<HsJSON>;+  using MapKeyType = HsString;+  using MapIterator = MapType::ConstIterator;+  using VectorType = HsArray<HsJSON>;+  using VectorIterator = VectorType::ConstIterator;+  using SetType = HsArray<HsJSON>;+  using SetIterator = SetType::ConstIterator;+  using StringType = HsString;+  using Type = facebook::serialize::Type;+  using StructHandle = int;++  /**+   * \defgroup as_type variant accessors+   * @{+   */+  static Type type(const VariantType& obj) {+    switch (obj.getType()) {+      case HsJSON::Type::Null:+        return Type::NULLT;+      case HsJSON::Type::Bool:+        return Type::BOOL;+      case HsJSON::Type::Integral:+        return Type::INT64;+      case HsJSON::Type::Real:+        return Type::DOUBLE;+      case HsJSON::Type::String:+        return Type::STRING;+      case HsJSON::Type::Array:+        return Type::VECTOR;+      case HsJSON::Type::Object:+        return Type::MAP;+      default:+        __builtin_unreachable();+    }+  }++  static bool asBool(const VariantType& obj) {+    return obj.asIntegral() != 0;+  }++  static int64_t asInt64(const VariantType& obj) {+    return obj.asIntegral();+  }++  static double asDouble(const VariantType& obj) {+    return obj.asReal();+  }++  static const StringType& asString(const VariantType& obj) {+    return obj.asString();+  }++  static const VectorType& asVector(const VariantType& obj) {+    return obj.asArray();+  }++  static const MapType& asMap(const VariantType& obj) {+    return obj.asObject();+  }++  static const SetType& asSet(const VariantType& obj) {+    return obj.asArray();+  }+  /** @} */++  /**+   * \defgroup to_variant variant creators+   * @{+   */+  static VariantType createNull() {+    return false;+  }+  static VariantType fromInt64(int64_t val) {+    return val;+  }+  static VariantType fromBool(bool val) {+    return val;+  }+  static VariantType fromDouble(double val) {+    return val;+  }+  static VariantType fromString(StringType&& str) {+    return std::move(str);+  }+  static VariantType fromMap(MapType&& map) {+    return std::move(map);+  }+  static VariantType fromVector(VectorType&& vec) {+    return std::move(vec);+  }+  static VariantType fromSet(SetType&& set) {+    return std::move(set);+  }+  /** @} */++  /**+   * \defgroup map map methods+   * @{+   */+  // builders+  static MapType createMap() {+    return MapType();+  }++  static MapType createMap(MapType&& m) {+    return MapType(std::move(m));+  }++  static MapType reserveMap(size_t n) {+    MapType ret;+    ret.reserve(n);+    return ret;+  }++  static MapType reserveMap(StructHandle, size_t n) {+    return reserveMap(n);+  }++  static MapType getStaticEmptyMap() {+    return createMap();+  }++  static MapKeyType mapKeyFromInt64(int64_t key) {+    return HsString(folly::to<std::string>(key));+  }++  static void mapSet(MapType& map, HsString&& key, VariantType&& value) {+    map.add(std::move(key), std::move(value));+  }++  static void mapSet(MapType& map, const HsString& key, VariantType&& value) {+    map.add(key, std::move(value));+  }++  static void mapSet(MapType& map, int64_t key, VariantType&& value) {+    map.add(mapKeyFromInt64(key), std::move(value));+  }++  template <typename T>+  static void+  mapSet(MapType& map, size_t /*idx*/, T&& key, VariantType&& value) {+    mapSet(map, std::forward<T>(key), std::move(value));+  }++  // accessors+  static Type mapKeyType(const MapKeyType& /*map*/) {+    return Type::STRING;+  }++  static int64_t mapKeyAsInt64(const MapKeyType& /*key*/) {+    throw std::runtime_error("mapKeyType should always be Type::STRING");+  }++  static HsString mapKeyAsString(const MapKeyType& key) {+    return key;+  }++  static MapIterator mapIterator(const MapType& map) {+    return map.getIterator();+  }++  static bool mapNotEnd(const MapType& /*map*/, const MapIterator& it) {+    return it.isValid();+  }++  static void mapNext(MapIterator& it) {+    it.next();+  }++  static const HsString& mapKey(const MapIterator& it) {+    return it.getKey();+  }++  static const HsJSON& mapValue(const MapIterator& it) {+    return it.getValue();+  }++  /** @} */++  /**+   * \defgroup vector vector methods+   * @{+   */+  // builders+  static VectorType createVector() {+    return VectorType();+  }++  static VectorType createVector(size_t size) {+    auto vec = VectorType();+    vec.reserve(size);+    return vec;+  }++  static int64_t vectorSize(const VectorType& vec) {+    return vec.size();+  }++  static void vectorAppend(VectorType& vec, VariantType&& v) {+    vec.add(std::move(v));+  }++  // accessors+  static VectorIterator vectorIterator(const VectorType& vec) {+    return vec.begin();+  }++  static bool vectorNotEnd(const VectorType& vec, VectorIterator& it) {+    return it != vec.end();+  }++  static void vectorNext(VectorIterator& it) {+    ++it;+  }++  static const VariantType& vectorValue(VectorIterator& it) {+    return *it;+  }+  /** @} */++  /**+   * \defgroup set set methods+   * @{+   */+  // builders+  static SetType createSet() {+    return SetType();+  }++  static SetType createSet(size_t size) {+    auto set = SetType();+    set.reserve(size);+    return set;+  }++  static int64_t setSize(const SetType& set) {+    return set.size();+  }++  static void setAppend(SetType& set, VariantType&& v) {+    set.add(std::move(v));+  }++  // accessors+  static SetIterator setIterator(const SetType& set) {+    return set.begin();+  }++  static bool setNotEnd(const SetType& set, SetIterator& it) {+    return it != set.end();+  }++  static void setNext(SetIterator& it) {+    ++it;+  }++  static const VariantType& setValue(SetIterator& it) {+    return *it;+  }+  /** @} */++  /**+   * \defgroup string string methods+   * @{+   */+  static StringType createString() {+    return std::string();+  }++  static StringType createMutableString(size_t n) {+    return std::string(n, '\0');+  }++  static char* getMutablePtr(StringType& str) {+    return str.mutable_data();+  }++  static void shrinkString(StringType& str, size_t n) {+    str.resize(n);+  }++  static StringType stringFromData(const char* src, int n) {+    return std::string(src, n);+  }++  static StringType stringFromMutableString(StringType&& s) {+    return std::move(s);+  }++  static StringType createStaticString(const char* src, int n) {+    return stringFromData(src, n);+  }++  static StringType getStaticEmptyString() {+    return std::string();+  }++  static void stringClear(StringType& str) {+    str.clear();+  }++  static int stringLen(const StringType& str) {+    return str.size();+  }++  static const char* stringData(const StringType& str) {+    return str.data();+  }++  static void stringAppend(StringType& str, const char* src, int n) {+    str.append(src, n);+  }++  static void stringAppend(StringType& str, const StringType& src) {+    str.append(src);+  }++  static void traceSerialization(const VariantType&) {}++  static StructHandle registerStruct(+      const StringType& stableIdentifier,+      const std::vector<std::pair<size_t, StringType>>& fields) {+    return -1;+  }+  /** @} */+};
+ cpp/IOBuf.cpp view
@@ -0,0 +1,36 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#include <cpp/IOBuf.h>++std::unique_ptr<folly::IOBuf> common::hs::newIOBufWrapping(HS_IOBuf* hs_iobuf) {+  auto ioBuf = folly::IOBuf::wrapBuffer(+      hs_iobuf->str_arr[hs_iobuf->len - 1],+      hs_iobuf->len_arr[hs_iobuf->len - 1]);+  for (int i = hs_iobuf->len - 2; i >= 0; i--) {+    auto last = std::move(ioBuf);+    ioBuf =+        folly::IOBuf::wrapBuffer(hs_iobuf->str_arr[i], hs_iobuf->len_arr[i]);+    ioBuf->appendChain(std::move(last));+  }++  return ioBuf;+}++extern "C" {++void get_iobuf_data(IOBuf* iobuf, IOBufData* iobuf_data) {+  iobuf_data->length_ = iobuf->length();+  iobuf_data->data_buf_ = iobuf->data();+  iobuf_data->next_ = iobuf->pop().release();+}++void destroy_iobuf(IOBuf* iobuf, uint8_t* /* buffer */) {+  delete iobuf;+}+}
+ cpp/IOBuf.h view
@@ -0,0 +1,41 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++#include <folly/io/IOBuf.h>++extern "C" {++struct HS_IOBuf {+  uint8_t** str_arr;+  size_t* len_arr;+  size_t len;+};++using folly::IOBuf;++struct IOBufData {+  int length_;+  const uint8_t* data_buf_;+  IOBuf* next_;+};++void get_iobuf_data(IOBuf* iobuf, IOBufData* iobuf_data);++void destroy_iobuf(IOBuf* iobuf, uint8_t* buffer);++} // extern "C"++namespace common {+namespace hs {++std::unique_ptr<folly::IOBuf> newIOBufWrapping(HS_IOBuf* hs_iobuf);++} // namespace hs+} // namespace common
+ cpp/Marshallable.h view
@@ -0,0 +1,17 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once+#include "cpp/Constructible.h"+#include "cpp/Destructible.h"++#ifndef HS_DEFINE_MARSHALLABLE+#define HS_DEFINE_MARSHALLABLE(Name, Type...) \+  HS_DEFINE_DEFAULT_CONSTRUCTIBLE(Name, Type) \+  HS_DEFINE_DESTRUCTIBLE(Name, Type)+#endif
+ cpp/RequestContext.h view
@@ -0,0 +1,51 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++#include <folly/io/async/Request.h>+#include <memory>+#include <optional>++// The address of folly::RequestContext should be constant and nonnull.+// The content of folly::RequestContext may be changed.+using RequestContextPtr = const std::shared_ptr<folly::RequestContext>;++namespace facebook::common::hs {++/**+ * In a foreign function call from Haskell to C++, the caller can pass an+ * explicit <tt>RequestContext</tt> (nonnull <tt>RequestContextPtr</tt>) or+ * <tt>Maybe RequestContext</tt> (nullable <tt>RequestContextPtr</tt>).+ * The C++ implementation should construct a \c RequestContextPtrScopeGuard+ * at the entry point to ensure the correct implicit \c folly::RequestContext+ * is always used in C++. There is usually no need to extend the lifetime of+ * this scope guard beyond the foreign function itself as long as all+ * async executions scheduled by it use async frameworks which are+ * RequestContext aware, e.g. folly futures and fibers.+ */+class RequestContextPtrScopeGuard {+ public:+  explicit RequestContextPtrScopeGuard(RequestContextPtr* rc) {+    if (rc != nullptr) {+      guard_.emplace(*rc);+    }+  }++  RequestContextPtrScopeGuard(const RequestContextPtrScopeGuard&) = delete;+  RequestContextPtrScopeGuard(RequestContextPtrScopeGuard&&) = delete;+  RequestContextPtrScopeGuard& operator=(const RequestContextPtrScopeGuard&) =+      delete;+  RequestContextPtrScopeGuard& operator=(RequestContextPtrScopeGuard&&) =+      delete;++ private:+  std::optional<folly::RequestContextScopeGuard> guard_;+};++} // namespace facebook::common::hs
+ cpp/cdynamic.cpp view
@@ -0,0 +1,193 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#include "cpp/cdynamic.h"++#include <folly/json/dynamic.h>+#include <folly/json/json.h>+#include <string.h>+#include "cpp/Destructible.h"++using namespace folly;++namespace facebook {+namespace hs {++/**+ * Read the type and value of a dynamic. If the dynamic is array or object,+ * its size is returned as the value.+ */+void readDynamic(const dynamic* d, DType* ty, DValue* val) noexcept {+  switch (d->type()) {+    case dynamic::STRING:+      *ty = tString;+      val->string = d->c_str();+      break;+    case dynamic::BOOL:+      *ty = tBool;+      val->boolean = d->asBool();+      break;+    case dynamic::DOUBLE:+      *ty = tDouble;+      val->doubl = d->asDouble();+      break;+    case dynamic::INT64:+      *ty = tInt64;+      val->int64 = d->asInt();+      break;+    case dynamic::ARRAY:+      *ty = tArray;+      val->size = d->size();+      break;+    case dynamic::OBJECT:+      *ty = tObject;+      val->size = d->size();+      break;+    case dynamic::NULLT:+      *ty = tNull;+      val->null = nullptr;+      break;+  }+}++/**+ * Read the fields of a dynamic array.  Memory for the array is+ * allocated by the caller.  The size of the array to allocate is+ * returned by readDynamic().+ */+int readDynamicArray(+    const dynamic* d,+    size_t /*size*/,+    const dynamic** elems) noexcept {+  if ((*d).type() != dynamic::ARRAY)+    return 0;++  int i = 0;+  for (const auto& e : *d) {+    elems[i++] = &e;+  }+  return i;+}++/**+ * Read the fields of a dynamic object.  Memory for the arrays are+ * allocated by the caller.  The size of the arrays to allocate is+ * returned by readDynamic().+ */+int readDynamicObject(+    const dynamic* d,+    size_t /*size*/,+    const dynamic** keys,+    const dynamic** vals) noexcept {+  if ((*d).type() != dynamic::OBJECT)+    return 0;++  // Relying on the iterator referring to elements by reference here.+  auto it = (*d).items();+  int i = 0;+  for (auto j = it.begin(); j != it.end(); ++j, ++i) {+    keys[i] = &(j->first);+    vals[i] = &(j->second);+  }+  return i;+}++/**+ * Create a dynamic with nullptr, boolean, double or const char*.+ * It's caller's responsibility to allocate and free the memory.+ */+void createDynamic(dynamic* ret, DType ty, DValue* val) noexcept {+  switch (static_cast<dynamic::Type>(ty)) {+    case dynamic::NULLT:+      new (ret) dynamic(nullptr);+      break;+    case dynamic::BOOL:+      new (ret) dynamic(val->boolean != 0);+      break;+    case dynamic::INT64:+      new (ret) dynamic(val->int64);+      break;+    case dynamic::DOUBLE:+      new (ret) dynamic(val->doubl);+      break;+    case dynamic::STRING:+      new (ret) dynamic(val->string);+      break;+    case dynamic::ARRAY:+      folly::terminate_with<std::invalid_argument>(+          "call writeDynamicArray for dynamic::ARRAY");+    case dynamic::OBJECT:+      folly::terminate_with<std::invalid_argument>(+          "call writeDynamicObject for dynamic::OBJECT");+    default:+      __builtin_unreachable();+  }+}++/**+ * Create a dynamic array with given \p elems.+ * It's caller's responsibility to allocate and free the memory for \p ret. The+ * elements of \p elems are invalidated.+ */+void createDynamicArray(dynamic* ret, size_t size, dynamic* elems) noexcept {+  new (ret) dynamic(dynamic::array);+  ret->resize(size);+  for (size_t i = 0; i < size; ++i) {+    ret->at(i) = std::move(elems[i]);+    elems[i].~dynamic();+  }+}++/**+ * Create a dynamic array with given \p keys and \p vals.+ * It's caller's responsibility to allocate and free the memory for \p ret. The+ * elements of \p vals are invalidated.+ */+void createDynamicObject(+    dynamic* ret,+    size_t size,+    const char** keys,+    dynamic* vals) noexcept {+  new (ret) dynamic(dynamic::object);+  for (size_t i = 0; i < size; ++i) {+    ret->insert(keys[i], std::move(vals[i]));+    vals[i].~dynamic();+  }+}++/**+ * parse JSON using folly::parseJson()+ * Returns either+ *  - a pointer to the folly::dynamic representing the parsed JSON. The caller+ *    owns this and is responsible for freeing it.+ *  - nullptr, and *err points to an error message. The caller owns the+ *    memory for the error message, and is responsible for freeing it.+ */+const folly::dynamic* parseJSON(+    const char* str,+    int64_t len,+    int recursion_limit,+    char** err) noexcept {+  json::serialization_opts opts;+  if (recursion_limit != -1) {+    opts.recursion_limit = recursion_limit;+  }++  try {+    auto d = parseJson(folly::StringPiece(str, len), opts);+    return new folly::dynamic(std::move(d));+  } catch (const std::exception& e) {+    *err = strdup(e.what());+    return nullptr;+  }+}++} // namespace hs+} // namespace facebook++HS_DEFINE_DESTRUCTIBLE(Dynamic, Dynamic)
+ cpp/cdynamic.h view
@@ -0,0 +1,53 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++#include <folly/json/dynamic.h>++using Dynamic = folly::dynamic;++enum DType { tNull, tArray, tBool, tDouble, tInt64, tObject, tString };++union DValue {+  void* null;+  int boolean;+  size_t size; /* array, object */+  double doubl;+  int64_t int64;+  const char* string;+};++namespace facebook {+namespace hs {++void readDynamic(const Dynamic* d, DType* ty, DValue* val) noexcept;++int readDynamicArray(+    const Dynamic* d,+    size_t size,+    const Dynamic** elems) noexcept;+int readDynamicObject(+    const Dynamic* d,+    size_t size,+    const Dynamic** keys,+    const Dynamic** vals) noexcept;++void createDynamic(Dynamic* ret, DType ty, DValue* val) noexcept;+void createDynamicArray(Dynamic* ret, size_t size, Dynamic* elems) noexcept;+void createDynamicObject(+    Dynamic* ret,+    size_t size,+    const char** keys,+    Dynamic* vals) noexcept;++const folly::dynamic*+parseJSON(const char* str, int64_t len, char** err) noexcept;++} // namespace hs+} // namespace facebook
+ cpp/ffi.cpp view
@@ -0,0 +1,31 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#include "cpp/ffi.h"+#include "cpp/wrap.h"++namespace facebook {+namespace hs {+namespace ffi {++const char* outOfMemory = "out of memory";+const char* unknownError = "unknown error";++} // namespace ffi+} // namespace hs+} // namespace facebook++extern "C" {++void hs_ffi_free_error(const char* err) {+  if (err != facebook::hs::ffi::outOfMemory &&+      err != facebook::hs::ffi::unknownError) {+    std::free(const_cast<char*>(err));+  }+}+}
+ cpp/ffi.h view
@@ -0,0 +1,19 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++#ifdef __cplusplus+extern "C" {+#endif++void hs_ffi_free_error(const char* error);++#ifdef __cplusplus+}+#endif
+ cpp/logging.cpp view
@@ -0,0 +1,49 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#include "cpp/logging.h"+#include <glog/logging.h>++int vlog_is_on(int level) noexcept {+  return VLOG_IS_ON(level);+}++#define LOG_EXT(severity, file, line) \+  google::LogMessage(file, line, ::google::GLOG_##severity).stream()++void glog_verbose(const char* file, int line, const char* msg) noexcept {+#ifdef GLOG_VERBOSE+  LOG_EXT(VERBOSE, file, line) << msg;+#else+  LOG_EXT(INFO, file, line) << msg;+#endif+}++void glog_info(const char* file, int line, const char* msg) noexcept {+  LOG_EXT(INFO, file, line) << msg;+}++void glog_warning(const char* file, int line, const char* msg) noexcept {+  LOG_EXT(WARNING, file, line) << msg;+}++void glog_error(const char* file, int line, const char* msg) noexcept {+  LOG_EXT(ERROR, file, line) << msg;+}++void glog_fatal(const char* file, int line, const char* msg) noexcept {+  LOG_EXT(FATAL, file, line) << msg;+}++void glog_flush() noexcept {+#ifdef GLOG_VERBOSE+  google::FlushLogFiles(google::GLOG_VERBOSE);+#else+  google::FlushLogFiles(google::GLOG_INFO);+#endif+}
+ cpp/logging.h view
@@ -0,0 +1,17 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++int vlog_is_on(int level) noexcept;++void glog_verbose(const char* file, int line, const char* msg) noexcept;+void glog_info(const char* file, int line, const char* msg) noexcept;+void glog_warning(const char* file, int line, const char* msg) noexcept;+void glog_error(const char* file, int line, const char* msg) noexcept;+void glog_fatal(const char* file, int line, const char* msg) noexcept;
+ cpp/memory.h view
@@ -0,0 +1,115 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++#include <folly/FBString.h>+#include <folly/Memory.h>+#include <folly/Range.h>++namespace facebook {+namespace hs {+namespace ffi {++/// A wrapper for a malloc'ed block of memory. Ownership can be release via+/// 'release' and 'release_to'; the memory must then be released manually via+/// 'free'. This makes it suitable for passing to Haskell.+template <typename T>+struct malloced_array {+  static_assert(+      std::is_trivially_destructible<T>::value,+      "malloced_array requires a trivially destructible type");++  malloced_array() noexcept : n(0) {}+  explicit malloced_array(size_t k)+      : ptr(folly::allocate_sys_buffer(k * sizeof(T))), n(k) {}+  malloced_array(folly::SysBufferUniquePtr&& p, size_t k) noexcept+      : ptr(std::move(p)), n(k) {}+  malloced_array(malloced_array&&) noexcept = default;+  malloced_array(const malloced_array&) = delete;++  malloced_array& operator=(malloced_array&& other) noexcept = default;+  malloced_array& operator=(const malloced_array&) = delete;++  template <typename U>+  void release_to(U** data, size_t* size) noexcept {+    *size = n;+    *data = release();+  }++  T* release() noexcept {+    n = 0;+    return static_cast<T*>(ptr.release());+  }++  T* get() const noexcept {+    return static_cast<T*>(ptr.get());+  }+  size_t size() const noexcept {+    return n;+  }++  T& operator[](size_t i) const noexcept {+    return get()[i];+  }++  void prune(size_t k) noexcept {+    assert(k <= n);+    n = k;+  }++ private:+  folly::SysBufferUniquePtr ptr;+  size_t n;+};++template <typename T>+malloced_array<T> malloc_array(size_t n) {+  return malloced_array<T>(n);+}++template <typename T>+malloced_array<T> clone_array(const T* data, size_t size, size_t pad = 0) {+  malloced_array<T> arr(size + pad);+  if (size != 0) {+    std::memcpy(arr.get(), data, size * sizeof(T));+  }+  return arr;+}++inline malloced_array<uint8_t>+clone_bytes(const void* data, size_t size, size_t pad = 0) {+  return clone_array<uint8_t>(static_cast<const uint8_t*>(data), size, pad);+}++inline malloced_array<uint8_t> clone_bytes(+    folly::ByteRange bytes,+    size_t pad = 0) {+  return clone_bytes(bytes.data(), bytes.size(), pad);+}++inline malloced_array<uint8_t> clone_bytes(+    const folly::fbstring& bytes,+    size_t pad = 0) {+  return clone_bytes(bytes.data(), bytes.size(), pad);+}++inline malloced_array<uint8_t> clone_bytes(+    const std::string& bytes,+    size_t pad = 0) {+  return clone_bytes(bytes.data(), bytes.size(), pad);+}++inline malloced_array<char> clone_string(const std::string& s, size_t pad = 0) {+  auto p = s.c_str();+  return clone_array(p, strlen(p) + 1, pad);+}++} // namespace ffi+} // namespace hs+} // namespace facebook
+ cpp/wrap.h view
@@ -0,0 +1,49 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++#include <cstring>+#include <stdexcept>++namespace facebook {+namespace hs {+namespace ffi {++extern const char* outOfMemory;+extern const char* unknownError;++template <typename F>+const char* wrap(F&& f) noexcept {+  try {+    f();+    return nullptr;+  } catch (const std::exception& e) {+    const char* s = strdup(e.what());+    return s == nullptr ? outOfMemory : s;+  } catch (...) {+    return unknownError;+  }+}++template <typename F>+void wrap_(F&& f) noexcept {+  try {+    f();+  } catch (...) {+  }+}++template <typename T>+void free_(T* obj) noexcept {+  wrap_([=] { delete obj; });+}++} // namespace ffi+} // namespace hs+} // namespace facebook
+ fb-util.cabal view
@@ -0,0 +1,481 @@+cabal-version:       3.6++-- Copyright (c) Facebook, Inc. and its affiliates.++name:                fb-util+version:             0.1.0.1+synopsis:            Various utility libraries+homepage:            https://github.com/facebookincubator/hsthrift+bug-reports:         https://github.com/facebookincubator/hsthrift/issues+license:             BSD-3-Clause+license-file:        LICENSE+author:              Facebook, Inc.+maintainer:          hsthrift-team@fb.com+copyright:           (c) Facebook, All Rights Reserved+category:            Utilities+build-type:          Simple+extra-source-files:  cpp/*.h,+                     tests/DynamicHelper.h,+                     tests/HsStructHelper.h,+                     hsc.h+extra-doc-files:     CHANGELOG.md++description:+    Utility libraries used by Meta projects, notably hsthrift and Glean.++    NOTE: for build instructions, see+    <https://github.com/facebookincubator/hsthrift>++source-repository head+    type: git+    location: https://github.com/facebookincubator/hsthrift.git++common fb-haskell+    default-language: Haskell2010+    default-extensions:+        BangPatterns+        BinaryLiterals+        DataKinds+        DeriveDataTypeable+        DeriveGeneric+        EmptyCase+        ExistentialQuantification+        FlexibleContexts+        FlexibleInstances+        GADTs+        GeneralizedNewtypeDeriving+        LambdaCase+        MultiParamTypeClasses+        MultiWayIf+        NoMonomorphismRestriction+        OverloadedStrings+        PatternSynonyms+        RankNTypes+        RecordWildCards+        ScopedTypeVariables+        StandaloneDeriving+        TupleSections+        TypeFamilies+        TypeSynonymInstances+        NondecreasingIndentation+    if flag(opt)+       ghc-options: -O2++common fb-cpp+  cxx-options: -std=c++17+  -- We use hsc2hs with C++ headers, so we need to compile the+  -- generated code with g++. The hsc2hs-generated binary is linked+  -- by ghc, because we depend on a Haskell package (mangle).+  hsc2hs-options: --cc=g++ --lflag=-lstdc++ --cflag=-D__HSC2HS__=1 --cflag=-std=c++17+  if !flag(clang)+     cxx-options: -fcoroutines+  if arch(x86_64)+     cxx-options: -march=haswell+  if flag(opt)+     cxx-options: -O3++flag opt+     default: False++flag clang+     default: False++-- Enable modules that depend on folly. Since folly normally needs to+-- be built from source, it is an inconvenient dependency. Without+-- folly we can still build thrift-compiler and the thrift-http+-- transport; only thrift-cpp-channel requires folly.+--+-- Ideally we'd split fb-util into two (or more) packages, or+-- sub-libraries. But that requires moving files around because the+-- Haskell sources would need to be in distinct directories, which needs+-- to be done in the upstream repository.+flag folly+     default: False++library+    import: fb-haskell, fb-cpp++    exposed-modules:+        Compat.Prettyprinter+        Compat.Prettyprinter.Util+        Compat.Prettyprinter.Render.Text+        Control.Concurrent.Stream+        Control.Trace+        Control.Trace.Core+        Control.Trace.VLog+        Data.MovingAverageRateLimiter+        Data.RateLimiterMap+        Util.ASan+        Util.Async+        Util.Aeson+        Util.AllocLimit+        Util.Applicative+        Util.Bag+        Util.Binary.Parser+        Util.Bits+        Util.Buffer+        Util.Build+        Util.ByteString+        Util.Concurrent+        Util.Control.Exception+        Util.Control.Exception.CallStack+        Util.Control.Monad+        Util.Defer+        -- Util.Dll+        Util.Encoding+        Util.Err+        Util.Fd+        Util.FFI+        Util.FilePath+        Util.Function+        Util.Graph+        -- Util.GFlags+        Util.HSE+        Util.HUnit+        Util.HashMap.Strict+        Util.IO+        Util.JSON.Pretty+        Util.Lens+        Util.Linter+        Util.List+        Util.List.HigherOrder+        Util.Log+        Util.Log.Text+        Util.Log.Internal+        Util.Log.String+        Util.LogIfSlow+        Util.Logger+        Util.MD5+        Util.Memory+        Util.Monoid+        Util.Network+        Util.OptParse+        Util.Predicate+        Util.PrettyPrint+        Util.RWVar+        Util.Reader+        Util.STM+        Util.Show+        Util.String+        Util.String.Quasi+        Util.Testing+        Util.Text+        Util.Time+        Util.TimeSec+        Util.Timing+        Util.ToExp+        Util.Typeable+        Util.WBVar++    cxx-sources:+        cpp/ffi.cpp+        cpp/logging.cpp+        Util/AsanAlloc.cpp+        -- Util/GFlags.cpp++    install-includes:+        cpp/ffi.h+        cpp/memory.h+        cpp/wrap.h+        Util/AsanAlloc.h++    include-dirs: .+    hs-source-dirs: .++    build-depends:+        HUnit ^>= 1.6.1,+        QuickCheck >= 2.14.3 && < 2.15,+        aeson < 2.3,+        aeson-pretty >= 0.8.10 && < 0.9,+        array ^>=0.5.2.0,+        async ^>=2.2.1,+        atomic-primops >= 0.8.8 && < 0.9,+        attoparsec >= 0.14.4 && < 0.15,+        attoparsec-aeson >= 2.1 && < 2.3,+        base >=4.11.1.0 && <4.20,+        binary ^>=0.8.5.1,+        bytestring >=0.10.8.2 && <0.13,+        bytestring-lexing >= 0.5.0 && < 0.6,+        clock >= 0.8.4 && < 0.9,+        concurrent-extra >= 0.7.0 && < 0.8,+        containers >=0.5.11 && <0.7,+        data-default >= 0.8.0 && < 0.9,+        deepseq >= 1.4.4 && < 1.6,+        directory ^>=1.3.1.5,+        either >= 5.0.2 && < 5.1,+        exceptions >= 0.10.4 && < 0.11,+        extra >= 1.8 && < 1.9,+        filepath ^>=1.4.2,+        ghc >= 8.6.5 && < 9.9,+        ghci >=8.6.5 && < 9.9,+        hashable >=1.2.7.0 && <1.5,+        haskell-src-exts >= 1.23.1 && < 1.24,+        integer-gmp >=1.0.2.0 && <1.2,+        json >= 0.11 && < 0.12,+        lens >= 5.3.3 && < 5.4,+        lifted-base >= 0.2.3 && < 0.3,+        mangle >= 0.1.0 && < 0.2,+        monad-control >= 1.0.3 && < 1.1,+        mtl >= 2.2.2 && < 2.4,+        optparse-applicative >= 0.17 && < 0.19,+        pretty ^>=1.1.3.6,+        prettyprinter >=1.2.1 && <1.8,+        primitive < 0.9,+        process ^>=1.6.3.0,+        scientific >= 0.3.7 && < 0.4,+        some >= 1.0.6 && < 1.1,+        split ^>=0.2.3.3,+        stm >= 2.5.0 && < 2.6,+        template-haskell >=2.13 && <2.22,+        text ^>=1.2.3.0,+        text-show >= 3.10.5 && < 3.12,+        time >=1.8.0.2 && <1.13,+        transformers >= 0.5.6 && < 0.7,+        unix >= 2.7.2.2 && < 2.9,+        unordered-containers ^>=0.2.9.0,+        vector >=0.12.0.1 && <0.14,++    build-tool-depends: hsc2hs:hsc2hs++    pkgconfig-depends: libglog, libevent, fmt, gflags+    if flag(folly)+        extra-libraries: double-conversion+    else+        pkgconfig-depends: double-conversion++    if flag(folly)+        exposed-modules:+            Foreign.CPP.Addressable+            Foreign.CPP.HsStruct+            Foreign.CPP.HsStruct.HsArray+            Foreign.CPP.HsStruct.HsOption+            Foreign.CPP.HsStruct.HsSet+            Foreign.CPP.HsStruct.HsStdTuple+            Foreign.CPP.HsStruct.HsMap+            Foreign.CPP.HsStruct.HsStdVariant+            Foreign.CPP.HsStruct.Unsafe+            Foreign.CPP.HsStruct.Types+            Foreign.CPP.HsStruct.Utils+            Foreign.CPP.Marshallable+            Foreign.CPP.Marshallable.TH+            Foreign.CPP.Dynamic+            Util.EventBase+            Util.Executor+            Util.IOBuf++        install-includes:+            cpp/HsOption.h+            cpp/HsStdTuple.h+            cpp/HsStdVariant.h+            cpp/HsStruct.h+            cpp/HsStructDefines.h++        cxx-sources:+            cpp/HsStruct.cpp+            cpp/cdynamic.cpp+            cpp/EventBaseDataplane.cpp+            cpp/Executor.cpp+            cpp/HsStruct.cpp+            cpp/IOBuf.cpp++        pkgconfig-depends: libfolly++common test-common+  extra-libraries: stdc+++  ghc-options: -threaded+  hs-source-dirs: tests, tests/github+  other-modules: SpecRunner+  build-depends: base,+                 aeson,+                 async,+                 binary,+                 bytestring,+                 containers,+                 directory,+                 fb-util,+                 fb-stubs,+                 filepath,+                 hspec,+                 hspec-contrib,+                 HUnit ^>= 1.6.1,+                 json,+                 lens,+                 mtl,+                 optparse-applicative,+                 prettyprinter,+                 QuickCheck,+                 regex-base,+                 regex-pcre,+                 scientific,+                 template-haskell,+                 temporary,+                 text,+                 text-show,+                 transformers,+                 unordered-containers,+                 vector++  build-tool-depends: hsc2hs:hsc2hs++  -- We use hsc2hs with C++ headers, so we need to compile the+  -- generated code with g++. The hsc2hs-generated binary is linked+  -- by ghc.+  hsc2hs-options: --cc=g++ --lflag=-lstdc++ --cflag=-D__HSC2HS__=1 --cflag=-std=c++17+++test-suite stream+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: StreamTest.hs+  ghc-options: -main-is StreamTest+test-suite movavgrl+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: MovingAverageRateLimiterTest.hs+  ghc-options: -main-is MovingAverageRateLimiterTest+test-suite rlmap+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: RateLimiterMapTest.hs+  ghc-options: -main-is RateLimiterMapTest+test-suite iobuf+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: IOBufTest.hs+  ghc-options: -main-is IOBufTest+  cxx-sources: tests/IOBufTest.cpp+  if !flag(folly)+     buildable: False+test-suite alloc-limit+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: AllocLimitTest.hs+  ghc-options: -main-is AllocLimitTest+test-suite unit-tests+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: UnitTests.hs+  ghc-options: -main-is UnitTests+test-suite rwvar+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: RWVarTest.hs+  ghc-options: -main-is RWVarTest+test-suite th+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: THTest.hs+  ghc-options: -main-is THTest+test-suite filepath+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: FilePathTest.hs+  ghc-options: -main-is FilePathTest+test-suite optparse+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: OptParseTest.hs+  ghc-options: -main-is OptParseTest+test-suite lens+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: LensTest.hs+  ghc-options: -main-is LensTest+test-suite toexp+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: ToExpTest.hs+  ghc-options: -main-is ToExpTest+test-suite aeson+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: AesonTest.hs+  ghc-options: -main-is AesonTest+test-suite buffer+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: BufferTest.hs+  ghc-options: -main-is BufferTest+test-suite exception+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: ExceptionTest.hs+  ghc-options: -main-is ExceptionTest+  if !flag(folly)+     buildable: False+test-suite control-exception+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: ControlExceptionTest.hs+  ghc-options: -main-is ControlExceptionTest+test-suite json-pretty+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: JSONPrettyTest.hs+  ghc-options: -main-is JSONPrettyTest+test-suite io+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: IOTest.hs+  ghc-options: -main-is IOTest+test-suite time-sec+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: TimeSecTest.hs+  ghc-options: -main-is TimeSecTest+test-suite list+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: ListTest.hs+  ghc-options: -main-is ListTest+test-suite graph+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: GraphTest.hs+  ghc-options: -main-is GraphTest+test-suite concurrent+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: ConcurrentTest.hs+  ghc-options: -main-is ConcurrentTest+test-suite md5+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: MD5Test.hs+  ghc-options: -main-is MD5Test+test-suite control-monad+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: Control/MonadTest.hs+  ghc-options: -main-is Control.MonadTest+test-suite string-quasi+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: StringQuasiTest.hs+  ghc-options: -main-is StringQuasiTest+test-suite dynamic+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: DynamicTest.hs+  cxx-sources: tests/DynamicHelper.cpp+  ghc-options: -main-is DynamicTest+  if !flag(folly)+     buildable: False+test-suite test-hs-struct+  import: fb-haskell, fb-cpp, test-common+  type: exitcode-stdio-1.0+  main-is: HsStructTest.hs+  other-modules: HsStructTestTypes+  cxx-sources: tests/HsStructHelper.cpp+  ghc-options: -main-is HsStructTest+  build-depends: extra+  if !flag(folly)+     buildable: False++-- TODO: commented out because of a linker problem+-- test-suite gflags+--   import: fb-haskell, fb-cpp, test-common+--   type: exitcode-stdio-1.0+--   main-is: GFlagsTest.hs+--   ghc-options: -main-is GFlagsTest+--   cxx-sources: tests/GFlagsTest.cpp
+ hsc.h view
@@ -0,0 +1,60 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++#include <HsFFI.h>++#include <stdio.h>+#include <stdlib.h>+#include <string.h>++/*+ * Utilities for use with hsc2hs.+ */++/*+ * #{ alignment T }+ *+ * Produces the minimal alignment of a data type.+ * NOTE: we can't use the macro that comes with hsc2hs, because+ * it doesn't build clearly under clang. TODO(14913295): upstream this+ */+#undef hsc_alignment+#define hsc_alignment(x...)                                           \+  do {                                                                \+    struct __anon_x__ {                                               \+      char a;                                                         \+      x b;                                                            \+    };                                                                \+    hsc_printf("%lu", (unsigned long)offsetof(struct __anon_x__, b)); \+  } while (0)++/*+ * #{ verbatim C++ code }+ *+ * Inserts any C++ code as it is in the code generator. An example use+ * case can be: #{ verbatim using namespace facebook::nodeapi; }+ */+#undef hsc_verbatim+#define hsc_verbatim(...) __VA_ARGS__++extern "C" HsPtr itaniumMangle(HsPtr a1, size_t l);++#define hsc_print_args(n)       \+  for (int i = 0; i < n; i++) { \+    hsc_printf("x%d ", i);      \+  }++#define hsc_check_unsafe_wrapper(f, n, sig)          \+  hsc_printf("%s_ %s\n", #f, #sig);                  \+  hsc_printf("%s %s\n", #f, #sig);                   \+  hsc_printf("%s ", #f);                             \+  hsc_print_args(n);                                 \+  hsc_printf("= checkUnsafe \"%s\" $ %s_ ", #f, #f); \+  hsc_print_args(n) hsc_printf("\n");
+ tests/AesonTest.hs view
@@ -0,0 +1,32 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module AesonTest (main) where++import Test.HUnit+import TestRunner++import Data.Aeson hiding (decode)+import Data.Char+import qualified Data.Text as Text++import Util.Aeson++utf16SurrogatesTest :: Test+utf16SurrogatesTest = TestLabel "UTF-16 surrogates" . TestCase $ do+  assertEqual "U+FFFF" (Just $ pack [0xFFFF]) (decode "\"\\uffff\"")+  assertEqual "U+24B62" (Just $ pack [0x24B62]) (decode "\"\\uD852\\uDF62\"")+  assertEqual "Invalid" (Nothing :: Maybe Value) (decode "\"\\uDF62\\uD852\"")+  where+  pack = String . Text.pack . map chr+  decode = either (const Nothing) Just . parseValueStrict++main :: IO ()+main = testRunner $ TestList+  [ utf16SurrogatesTest+  ]
+ tests/AllocLimitTest.hs view
@@ -0,0 +1,47 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE MagicHash #-}+module AllocLimitTest (main) where++import Test.HUnit+import TestRunner++import Util.AllocLimit++import Control.Exception+import GHC.Conc+import GHC.Exts++-- Test that GHC throws an alloc limit exception on code that *only*+-- allocates stack and not heap.+allocLimitStackTest :: Test+allocLimitStackTest = TestLabel "allocLimitStackTest" $ TestCase $ do+  let f :: Int# -> Int#+      f x = if isTrue# (x <# 0#)        -- avoid optimising away x+               then 1#+               else f (x +# 1#) -# 1#  -- should just grow the stack++  setAllocationCounter (10*1024*1024)+  enableAllocationLimit+  r <- try $ evaluate (isTrue# (f 0# ==# 0#))+  disableAllocationLimit+  assertBool "allocLimitTest" $ case r of+    Left e | Just AllocationLimitExceeded <- fromException e -> True+    _ -> False++limitAllocsTest :: Test+limitAllocsTest = TestLabel "limitAllocs" $ TestCase $ do+  e <- limitAllocs 10000 $ evaluate $ sum [(1::Integer)..]+  assertEqual "limitAllocs Nothing" Nothing e++main :: IO ()+main = testRunner $ TestList+  [ allocLimitStackTest+  , limitAllocsTest+  ]
+ tests/BufferTest.hs view
@@ -0,0 +1,75 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+module BufferTest (main) where++import Control.Monad.ST+import Control.Monad.ST.Unsafe+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BS+import Data.Word (Word8)+import Foreign.Marshal.Utils+import Foreign.Ptr (castPtr)+import Test.HUnit+import Test.QuickCheck++import Facebook.Init+import TestRunner+import Util.Testing++import qualified Util.Buffer as Buffer++data FillStep+  = FillByte Word8+  | FillByteString ByteString+  | FillAlloc Int ByteString+  deriving(Show)++stepToBS :: FillStep -> ByteString+stepToBS (FillByte x) = BS.singleton x+stepToBS (FillByteString x) = x+stepToBS (FillAlloc _ x) = x++step :: FillStep -> Buffer.Fill s ()+step (FillByte x) = Buffer.byte x+step (FillByteString x) = Buffer.byteString x+step (FillAlloc n x) = Buffer.alloc n $ \p -> unsafeIOToST $+  BS.unsafeUseAsCStringLen x $ \(q,k) -> do+    copyBytes p (castPtr q) k+    return k++instance Arbitrary ByteString where+  arbitrary = BS.pack <$> arbitrary++instance Arbitrary FillStep where+  arbitrary = oneof+    [ FillByte <$> arbitrary+    , FillByteString <$> arbitrary+    , (\(NonNegative n) s -> FillAlloc (BS.length s + n) s)+        <$> arbitrary+        <*> arbitrary+    ]++prop_fillByteString :: NonEmptyList (NonEmptyList FillStep) -> Property+prop_fillByteString ss =+  runST (Buffer.fillByteString 1+    $ foldr1 (\p q -> p >>= \_ -> q)+    $ map (foldr1 (>>) . map step) stepss+    )+  ===+  mconcat (map stepToBS $ concat stepss)+  where+    stepss = getNonEmpty <$> getNonEmpty ss++main :: IO ()+main = withFacebookUnitTest $ testRunner $ TestList+  [ TestLabel "fillByteString" $ TestCase $ assertProperty "mismatch"+      prop_fillByteString+  ]
+ tests/ConcurrentTest.hs view
@@ -0,0 +1,44 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# OPTIONS_GHC -Wno-name-shadowing #-}+module ConcurrentTest where++import Control.Exception+import Data.IORef++import Test.HUnit+import TestRunner++import Util.Concurrent++cacheSuccessTest :: Test+cacheSuccessTest = TestLabel "cacheSuccess" $ TestCase $ do+  c <- cacheSuccess (return (3::Int))+  r <- c+  assertEqual "cacheSuccess ok" r 3+  r <- c+  assertEqual "cacheSuccess ok2" r 3+  x <- newIORef (0::Int)+  c <- cacheSuccess (modifyIORef x (+1) >> readIORef x)+  r <- c+  assertEqual "cacheSuccess ok3" r 1+  r <- c+  assertEqual "cacheSuccess ok4" r 1+  x <- newIORef (0::Int)+  c <- cacheSuccess $ do+    modifyIORef x (+1); z <- readIORef x; throwIO $ ErrorCall $ show z+  r <- try c :: IO (Either ErrorCall ())+  assertEqual "cacheSuccess fail1" r (Left (ErrorCall "1"))+  r <- try c :: IO (Either ErrorCall ())+  assertEqual "cacheSuccess fail2" r (Left (ErrorCall "2"))++main :: IO ()+main = testRunner $ TestList+  [ cacheSuccessTest+  ]
+ tests/Control/MonadTest.hs view
@@ -0,0 +1,32 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Control.MonadTest (main) where++import Test.HUnit+import TestRunner++import Facebook.Init+import Util.Control.Monad++firstMLazyTest :: Test+firstMLazyTest = TestLabel "firstMLazy" . TestCase $ do+  r <- firstMLazy []+  assertEqual "Nothing" Nothing (r :: Maybe Int)++  r <- firstMLazy+    [ return Nothing+    , return $ Just 1+    , return $ Just 2+    , error "notFound"+    ]+  assertEqual "Just" (Just 1) (r :: Maybe Int)++main :: IO ()+main = withFacebookUnitTest $+  testRunner firstMLazyTest
+ tests/ControlExceptionTest.hs view
@@ -0,0 +1,35 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module ControlExceptionTest where++import Control.Exception+import Util.Control.Exception++import Test.HUnit+import TestRunner++import Facebook.Init (withFacebookUnitTest)++newtype MyException = MyException String deriving (Eq, Show)+instance Exception MyException++main :: IO ()+main = withFacebookUnitTest $ testRunner $ TestLabel "throwLeftIO" $ TestList+  [ TestLabel "with left" $ TestCase $ do+    let+      ex = MyException "bad!"+    (res :: Either MyException ()) <- try $ throwLeftIO $ Left ex+    assertEqual "throws the exception" res (Left ex)+  , TestLabel "with right" $ TestCase $ do+    let+      val = "good"+    (res :: Either MyException String) <- try $ throwLeftIO+      (Right val :: Either MyException String)+    assertEqual "returns the value" res (Right val)+  ]
+ tests/DynamicHelper.cpp view
@@ -0,0 +1,64 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#include "tests/DynamicHelper.h"++#include <fstream>++const folly::dynamic* newDynamic() noexcept {+  folly::dynamic* d = new folly::dynamic(folly::dynamic::object);++  d->insert("int", 42);+  d->insert("string", "wibble");+  d->insert("double", 1000.0 / 1024.0);+  d->insert("array", folly::dynamic::array(1, 2, 3));+  d->insert("null", nullptr);+  d->insert("object", folly::dynamic::object("a", "b"));+  d->insert("bool", true);++  return d;+}++const HsJSON* newHsJSON() noexcept {+  std::unique_ptr<const folly::dynamic> d(newDynamic());+  return new HsJSON(*d);+}++static std::string buf;++void initializeJson(const char* filename) noexcept {+  std::ifstream fin(filename);+  buf.assign(+      std::istreambuf_iterator<char>(fin), std::istreambuf_iterator<char>());+}++const char* getJsonAsCStringLen(int64_t* len) noexcept {+  *len = buf.size();+  return buf.data();+}++const folly::dynamic* getJsonAsPtrDynamic() noexcept {+  auto d = parseJson(folly::StringPiece(buf.data(), buf.size()));+  return new folly::dynamic(std::move(d));+}++const HsJSON* getJsonAsPtrHsJSON() noexcept {+  auto d = parseJson(folly::StringPiece(buf.data(), buf.size()));+  return new HsJSON(d);+}++const folly::dynamic* parseJSON(const char* str, int64_t len) noexcept {+  auto d = parseJson(folly::StringPiece(str, len));+  return new folly::dynamic(std::move(d));+}++int64_t compareDynamic(+    const folly::dynamic* lhs,+    const folly::dynamic* rhs) noexcept {+  return *lhs == *rhs ? 1 : 0;+}
+ tests/DynamicHelper.h view
@@ -0,0 +1,29 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++#include <folly/json/json.h>+#include "cpp/HsStruct.h"++extern "C" {++const folly::dynamic* newDynamic() noexcept;++const HsJSON* newHsJSON() noexcept;++void initializeJson(const char* filename) noexcept;+const char* getJsonAsCStringLen(int64_t* len) noexcept;+const folly::dynamic* getJsonAsPtrDynamic() noexcept;+const HsJSON* getJsonAsPtrHsJSON() noexcept;++const folly::dynamic* parseJSON(const char* str, int64_t len) noexcept;+int64_t compareDynamic(+    const folly::dynamic* lhs,+    const folly::dynamic* rhs) noexcept;+}
+ tests/DynamicTest.hs view
@@ -0,0 +1,90 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module DynamicTest (main) where++import Control.Exception (bracket)+import Data.Aeson hiding (parseJSON)+import qualified Data.ByteString.Lazy as LB+import Data.Either+import Data.Text (Text)+import Foreign+import System.Timeout (timeout)+import Test.HUnit+import TestRunner++import Foreign.CPP.Marshallable+import Foreign.CPP.Dynamic+import Foreign.CPP.HsStruct++expectedJSON :: Value+expectedJSON = object+  [ "int"    .= (42::Int)+  , "string" .= ("wibble" :: Text)+  , "double" .= (1000.0 / 1024.0 :: Double)+  , "array"  .= [(1::Int)..3]+  , "object" .= object ["a" .= ("b" :: Text)]+  , "null"   .= Null+  , "bool"   .= True+  ]++readDynamicTest :: Test+readDynamicTest = TestCase $ do+  json <- bracket newDynamic delete readDynamic+  assertEqual "readDynamicTest" expectedJSON json++peekHsJSONTest :: Test+peekHsJSONTest = TestCase $ do+  json <- bracket newHsJSON delete $ fmap hsJSON . peek+  assertEqual "peekHsJSONTest" expectedJSON json++withDynamicTest :: Test+withDynamicTest = TestCase $ do+  json <- withDynamic expectedJSON readDynamic+  assertEqual "withDynamicTest" expectedJSON json++nestedValueTest :: Test+nestedValueTest = TestCase $ do+  -- readDynamic should finish in linear time+  Just json <- timeout 1000000 $ withDynamic nestedJSON readDynamic+  assertEqual "nestedValueTest" nestedJSON json+  where+  nestedJSON = foldr ($!) (toJSON True) $+    take 5000 $ cycle [toArray, toObject]+  toArray v = toJSON [v]+  toObject v = object ["key" .= v]++parseJSONTest :: Test+parseJSONTest = TestCase $ do+  result <- parseJSON (LB.toStrict (encode expectedJSON))+  assertBool "parseJSON" $+    case result of+      Left _ -> False+      Right val -> val == expectedJSON++parseJSONError :: Test+parseJSONError = TestCase $ do+  result <- parseJSON "this is not JSON"+  print result+  assertBool "parseJSON" $ isLeft result++main :: IO ()+main = testRunner $ TestList $ map (uncurry TestLabel)+  [ ("readDynamicTest", readDynamicTest)+  , ("peekHsJSONTest", peekHsJSONTest)+  , ("withDynamicTest", withDynamicTest)+  , ("nestedValueTest", nestedValueTest)+  , ("parseJSONTest", parseJSONTest)+  , ("parseJSONError", parseJSONError)+  ]++foreign import ccall unsafe "newDynamic"+  newDynamic :: IO (Ptr Dynamic)++foreign import ccall unsafe "newHsJSON"+  newHsJSON :: IO (Ptr HsJSON)
+ tests/ExceptionTest.hs view
@@ -0,0 +1,93 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# OPTIONS_GHC -fno-warn-name-shadowing -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE OverloadedStrings #-}++module ExceptionTest (main) where++import Control.Exception+import Util.Control.Exception+import Test.HUnit+import TestRunner++catchAllTest :: Test+catchAllTest = TestLabel "catchAll" . TestCase $ do+  r <- (throwIO ThreadKilled `catchAll` \_ -> return 1)+      `catch` \SomeException{} -> return (2::Int)+  assertEqual "catchAll1" 2 r+  r <- (throwIO (ErrorCall "x") `catchAll` \_ -> return 1)+      `catch` \SomeException{} -> return (2::Int)+  assertEqual "catchAll2" 1 r++tryAllTest :: Test+tryAllTest = TestLabel "tryAll" . TestCase $ do+  r <- try (tryAll (throwIO ThreadKilled))+  assertBool "tryAll1" $ case r of+    Left x | Just ThreadKilled{} <- fromException x -> True+    _ -> False+  r <- try (tryAll (throwIO (ErrorCall "x")))+   :: IO (Either SomeException (Either SomeException Int))+  assertBool "tryAll2" $ case r of+    Right (Left x) | Just ErrorCall{} <- fromException x -> True+    _ -> False++tryBracketTest :: Test+tryBracketTest = TestLabel "tryBracket" . TestCase $ do+  r <- tryAll $ tryBracket+     (throwIO (ErrorCall "a"))+     (\_ _ -> throwIO (ErrorCall "b"))+     (\_ -> throwIO (ErrorCall "c"))+  assertBool "tryBracket1" $ case r of+    Left e | Just (ErrorCall "a") <- fromException e -> True+    _other -> False+  r <- tryAll $ tryBracket+     (return 'a')+     (\'a' _ -> throwIO (ErrorCall "b")) -- release throws; this is what we get+     (\'a' -> throwIO (ErrorCall "c"))+  assertBool "tryBracket2" $ case r of+    Left e | Just (ErrorCall "b") <- fromException e -> True+    _other -> False+  r <- tryAll $ tryBracket+     (return 'a')+     (\'a' Left{} -> return ())+     (\'a' -> throwIO (ErrorCall "c"))+  assertBool "tryBracket3" $ case r of+    Left e | Just (ErrorCall "c") <- fromException e -> True+    _other -> False+  r <- tryAll $ tryBracket+     (return 'a')+     (\'a' Right{} -> return ())+     (\'a' -> return 'c')+  assertBool "tryBracket4" $ case r of+    Right 'c' -> True+    _other -> False++tryFinallyTest :: Test+tryFinallyTest = TestLabel "tryFinally" . TestCase $ do+  r <- tryAll $ tryFinally+     (throwIO (ErrorCall "a"))+     (\Left{} -> throwIO (ErrorCall "b"))+  assertBool "tryFinally1" $ case r of+    Left e | Just (ErrorCall "b") <- fromException e -> True+    _other -> False+  r <- tryAll $ tryFinally+     (return 'a')+     (\Right{} -> throwIO (ErrorCall "b"))+        -- release throws; this is what we get+  assertBool "tryFinally2" $ case r of+    Left e | Just (ErrorCall "b") <- fromException e -> True+    _other -> False++main :: IO ()+main = testRunner $ TestList+  [ catchAllTest+  , tryAllTest+  , tryBracketTest+  , tryFinallyTest+  ]
+ tests/FilePathTest.hs view
@@ -0,0 +1,103 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module FilePathTest (main) where++import Data.Text (Text)++import Test.HUnit+import TestRunner++import Util.FilePath++dirEnv :: DirEnv+dirEnv = DirEnv{ homeDir = "/home/sweethome/", currentDir = "/herp" }++homeDirTest :: Test+homeDirTest = TestLabel "~/ handled" . TestCase $ do+  assertEqual "raw ~"+    "/home/sweethome/"+    (absolutiseWith dirEnv "~")+  assertEqual "~/derp"+    "/home/sweethome/derp"+    (absolutiseWith dirEnv "~/derp")+  assertEqual "relative path with ~"+    "/home/sweethome/../derp"+    (absolutiseWith dirEnv "~/../derp")++relPathTest :: Test+relPathTest = TestLabel "relative path handled" . TestCase $ do+  assertEqual "Relative path"+    "/herp/derp"+    (absolutiseWith dirEnv "derp")+  assertEqual "Relative path"+    "/herp/derp"+    (absolutiseWith dirEnv ".//derp")+  assertEqual "Relative path"+    "/herp/../derp"+    (absolutiseWith dirEnv "../derp")++testPathToMName :: Test+testPathToMName = TestList+  [ mkPathToModuleTestCase+      "Basic"+      "Foo/Bar/Baz/Quux.hs"+      "Foo.Bar.Baz.Quux"+  , mkPathToModuleTestCase+      "Rooted"+      "sigma/repo/Foo/Bar/Baz.hs"+      "Foo.Bar.Baz"+  , mkPathToModuleTestCase+      "Deeply rooted test"+      "sigma/repo/Foo.hs"+      "Foo"+  , mkPathToModuleTestCase+      "Absolute Filename"+      "/data/users/gnickstanley/si_sigma/Contexts/TestContext.hs"+      "Contexts.TestContext"+  , mkPathToModuleTestCase+      "Subproject Filename"+      "duckling/Duckling/Ranking/Types.hs"+      "Duckling.Ranking.Types"+  , mkPathToModuleTestCase+      "Rooted Subproject"+      "si_sigma/duckling/Duckling/Ranking/Types.hs"+      "Duckling.Ranking.Types"+  , mkPathToModuleTestCase+      "Absolute Subproject"+      "/data/users/gnickstanley/si_sigma/duckling/Duckling/Ranking/Types.hs"+      "Duckling.Ranking.Types"+  , mkPathToModuleTestCase+      "Other Capitalized Directories"+      "/data/users/ILOVECAPITALIZEDUSERNAMES/si_sigma/Contexts/TestContext.hs"+      "Contexts.TestContext"+  ]++mkPathToModuleTestCase :: String -> FilePath -> Text -> Test+mkPathToModuleTestCase name path expected =+  TestLabel name . TestCase $ expected @=? pathToMName path++testMNameToPath :: Test+testMNameToPath = TestList+  [ mkMNameToPathTestCase+      "Basic"+      "Foo.Bar.Baz.Quux"+      "Foo/Bar/Baz/Quux.hs"+  ]++mkMNameToPathTestCase :: String -> Text -> FilePath -> Test+mkMNameToPathTestCase name mname expected =+  TestLabel name . TestCase $ expected @=? mnameToPath mname++main :: IO ()+main = testRunner $ TestList+  [ homeDirTest+  , relPathTest+  , testPathToMName+  , testMNameToPath+  ]
+ tests/GraphTest.hs view
@@ -0,0 +1,49 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module GraphTest (main) where++import Control.Monad+import qualified Data.IntMap as IntMap+import Data.Maybe++import Test.QuickCheck+import Test.HUnit+import TestRunner+import Util.Graph++main :: IO ()+main = testRunner $ TestList+  [ TestLabel "postorder" $ TestCase $ do+      result <- quickCheckResult prop_postorder+      case result of+        Success{} -> return ()+        _ -> assertFailure "failed"+  ]++prop_postorder :: Property+prop_postorder = do+  forAll graphs $ \(nodes, outMap) ->+    check nodes outMap && check (reverse nodes) outMap+    -- regardless of the input order of the nodes, dependencies should+    -- appear before dependents in the output.+  where+  check nodes outMap =+    and [ posOf o < posOf n | n <- nodes, o <- out n ]+    where+      out n = fromJust (IntMap.lookup n outMap)+      order = postorder nodes id out+      pos = IntMap.fromList (zip order [(0::Int)..])+      posOf n = fromJust (IntMap.lookup n pos)++  graphs = do+    NonNegative numNodes <- arbitrary+    edges <- forM [1..numNodes] $ \n -> do+      outs <- sublistOf [1..n-1] -- only earlier nodes, so we get no cycles+      return (n,outs)+    return ([1..numNodes], IntMap.fromList edges)
+ tests/HsStructHelper.cpp view
@@ -0,0 +1,160 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#include "tests/HsStructHelper.h"++#include <map>+#include <string>+#include <tuple>+#include "cpp/HsStruct.h"++using namespace std;+using namespace std::string_literals;++namespace facebook::common::hs {++HS_DEFINE_DESTRUCTIBLE(HsMaybeNonmovable, HsMaybe<Nonmovable>);+HS_STD_TUPLE_CPP(CppTupleIntJSONOnlyMovable);+HS_STD_TUPLE_CPP(TupleStringString);++extern "C" {++HsMaybe<Nonmovable>* getHsMaybeNonmovable() noexcept {+  // test the std::unique_ptr constrcutor+  static HsMaybe<Nonmovable> ret(std::make_unique<Nonmovable>(9, "Crino"s));+  return &ret;+}++HsMaybe<Nonmovable>* createHsMaybeNonmovable(+    int64_t resource,+    const char* str,+    int64_t len) noexcept {+  // test the std::in_place_t constrcutor+  HsMaybe<Nonmovable> ret(std::in_place, resource, std::string(str, len));+  // HsMaybe itself is still safely movable+  return new HsMaybe<Nonmovable>(std::move(ret));+}++void fillCppTuple(hs_std_tuple::CppTupleIntJSONOnlyMovable* t) noexcept {+  *t = hs_std_tuple::CppTupleIntJSONOnlyMovable(std::make_tuple(+      42,+      true,+      facebook::common::hs::OnlyMovable(8),+      HsEither<HsString, int64_t>(HsLeft, HsString("wut"s))));+}++} // extern "C"++} // namespace facebook::common::hs++HS_STD_VARIANT_CPP(MyCppVariant);+HS_OPTION_CPP(MyCppVariant, hs_std_variant::MyCppVariant);+HS_OPTION_CPP(TupleStringString, FB_SINGLE_ARG(HsStdTuple<HsString, HsString>));++extern "C" {++bool checkHsText(HsString val, const char* str, size_t len) {+  return val.getStr() == std::string(str, len);+}++bool checkHsEither(HsEither<HsString, int>* val, int left_or_right) {+  switch (left_or_right) {+    case 1:+      return val->getLeft().getStr() == "string from haskell";+    case 2:+      return val->getRight() == 42;+    default:+      throw std::runtime_error(std::string(+          "checkHsEither: left_or_right should be either 1 or 2. Given: %d",+          left_or_right));+  }+}++HsMaybe<HsString>* getNothing() noexcept {+  static HsMaybe<HsString> ret;+  return &ret;+}++HsMaybe<HsString>* getJust() noexcept {+  static HsMaybe<HsString> ret("just"s);+  return &ret;+}++HsEither<HsString, int64_t>* getLeft() noexcept {+  static HsEither<HsString, int64_t> ret(HsLeft, "error"s);+  return &ret;+}++HsEither<HsString, int64_t>* getRight() noexcept {+  static HsEither<HsString, int64_t> ret(HsRight, 42);+  return &ret;+}++HsArray<HsString>* getArray() noexcept {+  static HsArray<HsString> ret{"foo"s, "bar"s};+  return &ret;+}++HsArray<int64_t>* getArrayInt64() noexcept {+  static HsArray<int64_t> ret{1, 2, 3};+  return &ret;+}++// HsArrayBool uses bytes because std::vector<bool> does+// not use a contiguous array representation+HsArray<uint8_t>* getArrayCBool() noexcept {+  static HsArray<uint8_t> ret{true, false, true, true, true, false};+  return &ret;+}++HsSet<HsString>* getSet() noexcept {+  static HsSet<HsString> ret{"foo"s, "bar"s};+  return &ret;+}++HsSet<int64_t>* getSetInt64() noexcept {+  static HsSet<int64_t> ret{1, 2, 3};+  return &ret;+}++HsIntMap<int64_t>* getIntMap() noexcept {+  static HsIntMap<int64_t> ret{{2, 4}, {3, 9}, {5, 25}, {7, 49}};+  return &ret;+}++HsMap<int64_t, int64_t>* getIntHashMap() noexcept {+  static HsMap<int64_t, int64_t> ret{{2, 4}, {3, 9}, {5, 25}, {7, 49}};+  return &ret;+}++HsPair<HsString, int64_t>* getPair() noexcept {+  static auto ret = HsPair<HsString, int64_t>("foo"s, 3);+  return &ret;+}++using HsNested = HsObject<HsIntMap<HsArray<HsMaybe<HsString>>>>;++HsNested* createNested() noexcept {+  map<string, map<int64_t, vector<folly::Optional<HsString>>>> ret;+  ret["zero"];+  ret["one"][1];+  ret["two"][2].emplace_back(folly::none);+  auto& more = ret["more"];+  more[3].emplace_back(folly::none);+  more[4].emplace_back("two"s);+  more[5].emplace_back(folly::none);+  more[5].emplace_back(""s);+  more[6].emplace_back("two"s);+  more[6].emplace_back("three"s);+  return new HsNested(std::move(ret));+}++void destroyNested(HsNested* p) noexcept {+  delete p;+}+}
+ tests/HsStructHelper.h view
@@ -0,0 +1,60 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#pragma once++#include <folly/Preprocessor.h>+#include "cpp/HsStruct.h"++namespace facebook::common::hs {++HS_STRUCT OnlyMovable {+  int64_t r_;++ public:+  OnlyMovable() = delete;+  explicit OnlyMovable(int64_t r) : r_(r) {}++  OnlyMovable(const OnlyMovable&) = delete;+  OnlyMovable& operator=(const OnlyMovable&) = delete;++  OnlyMovable(OnlyMovable&&) = default;+  OnlyMovable& operator=(OnlyMovable&&) = delete;+};++HS_STRUCT Nonmovable {+  int64_t resource;+  HsString description;++ public:+  Nonmovable(int64_t resource, std::string && description)+      : resource(resource), description(std::move(description)) {}++  ~Nonmovable() {+    // free_resource(resource);+  }++  Nonmovable(const Nonmovable&) = delete;+  Nonmovable(Nonmovable&&) = delete;+  Nonmovable& operator=(const Nonmovable&) = delete;+  Nonmovable& operator=(Nonmovable&&) = delete;+};++} // namespace facebook::common::hs++HS_STD_VARIANT_H(MyCppVariant, int32_t, HsString, HsOption<HsJSON>);+HS_OPTION_H(MyCppVariant, hs_std_variant::MyCppVariant);+HS_STD_TUPLE_H(+    CppTupleIntJSONOnlyMovable,+    FB_SINGLE_ARG(+        int32_t,+        HsJSON,+        facebook::common::hs::OnlyMovable,+        HsEither<HsString, int64_t>));+HS_STD_TUPLE_H(TupleStringString, FB_SINGLE_ARG(HsString, HsString));+HS_OPTION_H(TupleStringString, FB_SINGLE_ARG(HsStdTuple<HsString, HsString>));
+ tests/HsStructTest.hs view
@@ -0,0 +1,495 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module HsStructTest (main) where++import Test.HUnit+import TestRunner++import Control.Exception+import qualified Data.Aeson as Aeson+import Data.ByteString (ByteString, useAsCStringLen)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Map.Strict as Map+import Data.Scientific (Scientific, fromFloatDigits)+import Data.Text (Text)+import qualified Data.Text.Encoding as Text (encodeUtf8)+import Data.Tuple.Extra ((***))+import qualified Data.Vector as Vector+import qualified Data.Vector.Storable as VectorStorable+import Foreign+import Foreign.C.Types (CBool (..), CChar)++import Foreign.CPP.HsStruct+import Foreign.CPP.Marshallable+import Util.Aeson++import qualified HsStructTestTypes as TT++foreign import ccall unsafe "fillCppTuple"+  c_fillCppTuple :: Ptr (HsStdTuple (Int32, HsJSON, TT.OnlyMovable, HsEither HsText Int)) -> IO ()++stdTupleTest :: Test+stdTupleTest = TestLabel "stdTupleTest" $ TestCase $ do+  withCxxObject (HsStdTuple t_val) (testTuple "tuple roundtrip")++  withDefaultCxxObject $ \ptr -> do+    c_fillCppTuple ptr+    testTuple "peeked" ptr++  where+    i_val = 42 :: Int32+    j_val = Aeson.Bool True+    n_val = TT.OnlyMovable 8+    e_val = Left (HsText "wut") :: Either HsText Int+    t_val = (i_val, HsJSON j_val, n_val, HsEither e_val)++    testTuple pref ptr = do+      (HsStdTuple (peeked_i, HsJSON peeked_j, peeked_n, HsEither peeked_e)) <-+        peek ptr+      assertEqual (pref ++ " int") i_val peeked_i+      assertEqual (pref ++ " json") j_val peeked_j+      assertEqual (pref ++ " OnlyMovable") n_val peeked_n+      case (e_val, peeked_e) of+        (Left (HsText a), Left (HsText b)) ->+          assertEqual (pref ++ " Either") a b+        _ -> assertFailure (pref ++ " Either peeking failed")++stdVariantTest :: Test+stdVariantTest = TestLabel "stdVariantTest" $+  TestCase $ do+    let i_val = 1337+    withCxxObject (TT.I i_val) $ \i_p -> do+      peeked_i <- peek i_p :: IO TT.MyVariant+      case peeked_i of+        TT.I peeked_i_val -> assertEqual "int roundtrip" i_val peeked_i_val+        _ -> assertFailure "Didn't get int back from roundtrip"++    let s_val = "WUT"+    withCxxObject (TT.S (HsByteString s_val)) $ \s_p -> do+      peeked_s <- peek s_p :: IO TT.MyVariant+      case peeked_s of+        TT.S (HsByteString peeked_s_val) ->+          assertEqual "string roundtrip" s_val peeked_s_val+        _ -> assertFailure "Didn't get string back from roundtrip"++    let opt_val = TT.J (HsOption (Just (HsJSON (Aeson.Bool True))))+    withCxxObject (HsOption (Just opt_val)) $ \j_p -> do+      HsOption peeked_j <- peek j_p :: IO (HsOption TT.MyVariant)+      case peeked_j of+        Just (TT.J (HsOption (Just (HsJSON (Aeson.Bool v))))) ->+          assertBool "Json bool roundtrip" v+        _ -> assertFailure "Didn't get option of Json back"++arrayCxxTest :: Test+arrayCxxTest = TestLabel "arrayCxxTest" $+  TestCase $ do+    withDefaultCxxObject $ \p -> do+      HsList v <- peek p :: IO (HsList HsText)+      assertEqual "default is empty" [] (map hsText v)++    let pokey = ["1", "2", "3"]+    withCxxObject (HsList (map HsText pokey)) $ \p -> do+      HsList v <- peek p+      assertEqual "list of strings" pokey (map hsText v)++    withDefaultCxxObject $ \p -> do+      HsArray v <- peek p :: IO (HsArray HsText)+      assertEqual "default is empty" [] (map hsText (Vector.toList v))++    withCxxObject (HsArray (Vector.fromList (map HsText pokey))) $ \p -> do+      HsArray v <- peek p+      assertEqual "array of strings" pokey (Vector.toList (Vector.map hsText v))++    let booley = fmap toCBool [False, True, True, False, False, True]+    withCxxObject (HsArray (Vector.fromList booley)) $ \p -> do+      HsArray v <- peek p+      assertEqual "array of bool" booley (Vector.toList v)++setCxxTest :: Test+setCxxTest = TestLabel "setCxxTest" $+  TestCase $ do+    withDefaultCxxObject $ \p -> do+      HsHashSet s <- peek p :: IO (HsHashSet HsText)+      assertEqual+        "default is empty"+        HashSet.empty+        (HashSet.map hsText s)++    let pokey = ["1", "2", "3", "2"]+    let pokeySet = HashSet.fromList pokey+    withCxxObject (HsHashSet $ HashSet.map HsText pokeySet) $ \p -> do+      HsHashSet s <- peek p+      assertEqual+        "set of strings"+        pokeySet+        (HashSet.map hsText s)++    let pokeyInt :: [Int] = [1, 2, 3, 2]+    let pokeyIntSet = HashSet.fromList pokeyInt+    withCxxObject (HsHashSet pokeyIntSet) $ \p -> do+      HsHashSet s <- peek p+      assertEqual "set of ints" pokeyIntSet s++    let pokeyDouble :: [Double] = [1.0, 2.0, 3.0, 2.0]+    let pokeyDoubleSet = HashSet.fromList pokeyDouble+    withCxxObject (HsHashSet pokeyDoubleSet) $ \p -> do+      HsHashSet s <- peek p+      assertEqual+        "set of doubles"+        pokeyDoubleSet+        s++mapCxxTest :: Test+mapCxxTest = TestLabel "mapCxxTest" $+  TestCase $ do+    let map_kv = \kf vf -> HashMap.fromList . map (kf *** vf) . HashMap.toList+    withDefaultCxxObject $ \p -> do+      HsHashMap s <- peek p :: IO (HsHashMap HsText HsText)+      assertEqual+        "default is empty"+        HashMap.empty+        (map_kv hsText hsText s)++    let pokey :: [(Text, Text)] =+          [("1", "a"), ("2", "b"), ("3", "c")]+    let pokeyMap = HashMap.fromList pokey+    withCxxObject (HsHashMap $ map_kv HsText HsText pokeyMap) $ \p -> do+      HsHashMap s <- peek p+      assertEqual+        "map from strings to strings"+        pokeyMap+        (map_kv hsText hsText s)++    let pokeyDuplicate :: [(Text, Text)] =+          [("1", "a"), ("2", "b"), ("3", "c"), ("2", "d")]+    let pokeyDuplicateMap = HashMap.fromList pokeyDuplicate+    withCxxObject (HsHashMap $ map_kv HsText HsText pokeyDuplicateMap) $ \p ->+      do+        HsHashMap s <- peek p+        assertEqual+          "map from strings to strings with duplicates"+          pokeyDuplicateMap+          (map_kv hsText hsText s)++    let pokeyInt :: [(Int32, Text)] = [(1, "a"), (2, "b"), (3, "c"), (2, "d")]+    let pokeyIntMap = HashMap.fromList pokeyInt+    withCxxObject (HsHashMap $ map_kv id HsText pokeyIntMap) $ \p -> do+      HsHashMap s <- peek p+      assertEqual+        "map from ints to strings with duplicates"+        pokeyIntMap+        (map_kv id hsText s)++    let pokeyDouble :: [(Double, Int32)] =+          [(1.0, 19), (2.0, 29), (3.0, 39), (2.0, 9)]+    let pokeyDoubleMap = HashMap.fromList pokeyDouble+    withCxxObject (HsHashMap pokeyDoubleMap) $ \p -> do+      HsHashMap s <- peek p+      assertEqual+        "map from doubles to ints with duplicates"+        pokeyDoubleMap+        s++toCBool :: Bool -> CBool+toCBool = fromBool++stringPieceCxxTest :: Test+stringPieceCxxTest = TestLabel "stringPieceCxxTest" $+  TestCase $ do+    withDefaultCxxObject $ \p -> do+      HsRange ptr len <- peek p :: IO HsStringPiece+      assertEqual "ptr" nullPtr ptr+      assertEqual "len" 0 len++    let pokeString = "pokey" :: ByteString+    useAsCStringLen pokeString $ \(pPtr, pLen) ->+      withCxxObject (HsRange pPtr pLen) $ \p -> do+        HsRange rPtr rLen <- peek p+        assertEqual "rPtr" pPtr rPtr+        assertEqual "rLen" pLen rLen++optionTest :: Test+optionTest = TestLabel "optionTest" $+  TestCase $ do+    withDefaultCxxObject $ \p -> do+      HsOption v <- peek p+      case v of+        Just (HsText _) -> assertFailure "Should not have received anything"+        Nothing -> return ()++    let pokeString = "pokey"+    withCxxObject (HsOption (Just $ HsText pokeString)) $ \p -> do+      HsOption o <- peek p+      case o of+        Just (HsText v) -> assertEqual "alloc text was set" pokeString v+        Nothing -> assertFailure "Should have received something"++    let pokeVal = 5 :: Int64+    withCxxObject (HsOption (Just pokeVal)) $ \p -> do+      HsOption o <- peek p+      case o of+        Just v -> assertEqual "alloc int was set" pokeVal v+        Nothing -> assertFailure "Should have received something"++allocUtilsTest :: Test+allocUtilsTest = TestLabel "allocUtilsTest" $+  TestCase $ do+    let pokeString = "pokey"+    withDefaultCxxObject $ \p -> do+      assign p (HsText pokeString)+      HsText v <- peek p+      assertEqual "poked string was set" pokeString v++    withCxxObject (HsText pokeString) $ \p -> do+      HsText v <- peek p+      assertEqual "alloc string was set" pokeString v++foreign import ccall unsafe "checkHsText"+  c_checkHsText :: Ptr HsText -> Ptr CChar -> Word -> IO CBool++pokeHsTextTest :: Test+pokeHsTextTest = TestLabel "pokeHsTextTest" $+  TestCase $ do+    let ctorString = "constructed string"+        pokeString = "poked string"+    withCxxObject (HsText ctorString) $ \p -> do+      check_1 <- unsafeUseAsCStringLen (Text.encodeUtf8 ctorString) $+        \(str, len) -> c_checkHsText p str (fromIntegral len)+      assertBool "constructed string not matches" (toBool check_1)++      assign p (HsText pokeString)+      check_2 <- unsafeUseAsCStringLen (Text.encodeUtf8 pokeString) $+        \(str, len) -> c_checkHsText p str (fromIntegral len)+      assertBool "poked string not matches" (toBool check_2)++maybeTest :: Test+maybeTest = TestLabel "Maybe" $+  TestCase $ do+    (nothing :: Maybe String) <- coerce $ peek =<< getNothing+    assertEqual "Nothing" Nothing nothing+    (just :: Maybe String) <- coerce $ peek =<< getJust+    assertEqual "Just Text" (Just "just") just++foreign import ccall unsafe "getNothing"+  getNothing :: IO (Ptr (HsMaybe HsString))++foreign import ccall unsafe "getJust"+  getJust :: IO (Ptr (HsMaybe HsString))++maybeNonmovableTest :: Test+maybeNonmovableTest = TestLabel "HsMaybeNonmovable" $+  TestCase $ do+    HsMaybe got <- peek =<< getHsMaybeNonmovable+    assertEqual "get" (Just $ TT.Nonmovable 9 "Crino") got+    p <- unsafeUseAsCStringLen descritpion $ \(str, len) ->+      mask_ $ toSharedPtr =<< createHsMaybeNonmovable 101 str len+    HsMaybe created <- withForeignPtr p peek+    assertEqual "created" (Just $ TT.Nonmovable 101 descritpion) created+  where+    descritpion = "descritpion"++foreign import ccall unsafe "getHsMaybeNonmovable"+  getHsMaybeNonmovable :: IO (Ptr (HsMaybe TT.Nonmovable))++foreign import ccall unsafe "createHsMaybeNonmovable"+  createHsMaybeNonmovable ::+    Int -> Ptr CChar -> Int -> IO (Ptr (HsMaybe TT.Nonmovable))++peekHsEitherTest :: Test+peekHsEitherTest = TestLabel "peekHsEitherTest" $+  TestCase $ do+    (left :: Either String Int) <- coerce $ peek =<< getLeft+    assertEqual "Left" (Left "error") left+    (right :: Either String Int) <- coerce $ peek =<< getRight+    assertEqual "Right" (Right 42) right++foreign import ccall unsafe "getLeft"+  getLeft :: IO (Ptr (HsEither HsString Int))++foreign import ccall unsafe "getRight"+  getRight :: IO (Ptr (HsEither HsString Int))++pokeHsEitherTest :: Test+pokeHsEitherTest = TestLabel "pokeHsEitherTest" $+  TestCase $ do+    let initialValue :: HsEither HsText Int+        initialValue = HsEither (Left (HsText "string from haskell"))+        updatedValue :: HsEither HsText Int+        updatedValue = HsEither (Right 42)+    withCxxObject initialValue $ \p -> do+      check_1 <- c_checkHsEither p 1+      assertBool "Left value not matches" (toBool check_1)+      assign p updatedValue+      check_2 <- c_checkHsEither p 2+      assertBool "Right value not matches" (toBool check_2)++foreign import ccall unsafe "checkHsEither"+  c_checkHsEither :: Ptr (HsEither HsText Int) -> Int -> IO CBool++arrayTest :: Test+arrayTest = TestLabel "Array" $+  TestCase $ do+    s <- fmap (fmap hsString . hsArray) $ peek =<< getArray+    assertEqual "Vector String" (Vector.fromList ["foo", "bar"]) s+    bs <- fmap (map hsByteString . hsList) $ peek =<< getArray+    assertEqual "[ByteString]" ["foo", "bar"] bs+    t <- fmap (map hsText . hsList) $ peek =<< getArray+    assertEqual "[Text]" ["foo", "bar"] t+    v <- fmap hsArrayStorable $ peek =<< getArrayInt64+    assertEqual "VectorStorable Int64" (VectorStorable.fromList [1 :: Int64, 2, 3]) v+    bv <- fmap hsArray $ peek =<< getArrayCBool+    assertEqual "CBool Size" 1 (sizeOf (CBool 0))+    assertEqual "CBool Align" 1 (alignment (CBool 1))+    let expected = fmap toCBool [True, False, True, True, True, False]+    assertEqual "Vector Bool" (Vector.fromList expected) bv++foreign import ccall unsafe "getArray"+  getArray :: IO (Ptr a)++foreign import ccall unsafe "getArrayInt64"+  getArrayInt64 :: IO (Ptr a)++foreign import ccall unsafe "getArrayCBool"+  getArrayCBool :: IO (Ptr a)++setTest :: Test+setTest = TestLabel "Set" $+  TestCase $ do+    s :: HsHashSet HsText <- peek =<< getSet+    assertEqual+      "HashSet String"+      (HashSet.fromList ["foo", "bar"])+      (HashSet.map hsText $ hsHashSet s)++    si :: HsHashSet Int64 <- peek =<< getSetInt64+    assertEqual+      "HashSet Int64"+      (HashSet.fromList [1, 2, 3])+      (hsHashSet si)++foreign import ccall unsafe "getSet"+  getSet :: IO (Ptr a)++foreign import ccall unsafe "getSetInt64"+  getSetInt64 :: IO (Ptr a)++mapTest :: Test+mapTest = TestLabel "Map" $+  TestCase $ do+    HsMap m <- peek =<< getIntMap+    assertEqual "Map Int Int" (Map.fromList assocs) m+    HsIntMap im <- peek =<< getIntMap+    assertEqual "IntMap Int" (IntMap.fromList assocs) im+    HsHashMap hm <- peek =<< getIntHashMap+    assertEqual+      "HashMap Int Int"+      (HashMap.fromList assocs)+      hm+  where+    assocs = [(2, 4), (3, 9), (5, 25), (7, 49)] :: [(Int, Int)]++foreign import ccall unsafe "getIntMap"+  getIntMap :: IO (Ptr a)++foreign import ccall unsafe "getIntHashMap"+  getIntHashMap :: IO (Ptr a)++pairTest :: Test+pairTest = TestLabel "Pair" $+  TestCase $ do+    HsPair (HsText f, s) :: HsPair HsText Int <- peek =<< getPair+    assertEqual "Pair" ("foo", 3) (f, s)++foreign import ccall unsafe "getPair"+  getPair :: IO (Ptr a)++type Nested = KeyMap (IntMap [Maybe Text])+type HsNested = HsObject (HsIntMap (HsList (HsMaybe HsText)))++nestedTest :: Test+nestedTest = TestLabel "nested" $+  TestCase $ do+    actual :: Nested <- coerce $ bracket createNested destroyNested peek+    assertEqual "Nested" expected actual+  where+    expected =+      objectFromList+        [ (keyFromText "zero", IntMap.empty)+        , (keyFromText "one", IntMap.singleton 1 [])+        , (keyFromText "two", IntMap.singleton 2 [Nothing])+        ,+          ( keyFromText "more"+          , IntMap.fromList+              [ (3, [Nothing])+              , (4, [Just "two"])+              , (5, [Nothing, Just ""])+              , (6, [Just "two", Just "three"])+              ]+          )+        ]++foreign import ccall unsafe "createNested"+  createNested :: IO (Ptr HsNested)++foreign import ccall unsafe "destroyNested"+  destroyNested :: Ptr HsNested -> IO ()++jsonRoundTrip :: Test+jsonRoundTrip = TestLabel "json" $+  TestCase $ do+    roundTrip Aeson.Null+    roundTrip (Aeson.Bool True)+    roundTrip (Aeson.Bool False)+    roundTrip (Aeson.Number (read "42" :: Scientific))+    roundTrip (Aeson.Number (read "-42" :: Scientific))+    roundTrip (Aeson.Number (fromFloatDigits (3.14159 :: Double)))+    roundTrip (Aeson.String "Data.Aeson")+    roundTrip+      ( Aeson.Array $+          Vector.fromList+            [Aeson.Null, Aeson.Bool True, Aeson.String "VectorVector"]+      )+    roundTrip+      ( Aeson.Object $+          objectFromList+            [(keyFromText "foo", Aeson.Bool True), (keyFromText "bar", Aeson.Bool False)]+      )+  where+    roundTrip j = withCxxObject (HsJSON j) $ \p -> do+      HsJSON v <- peek p+      assertEqual "json round trip" j v++main :: IO ()+main =+  testRunner $+    TestList+      [ pokeHsTextTest+      , maybeTest+      , maybeNonmovableTest+      , peekHsEitherTest+      , pokeHsEitherTest+      , arrayTest+      , mapCxxTest+      , mapTest+      , pairTest+      , nestedTest+      , allocUtilsTest+      , optionTest+      , arrayCxxTest+      , setCxxTest+      , setTest+      , stringPieceCxxTest+      , jsonRoundTrip+      , stdVariantTest+      , stdTupleTest+      ]
+ tests/HsStructTestTypes.hsc view
@@ -0,0 +1,84 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module HsStructTestTypes+  ( Nonmovable(..)+  , OnlyMovable(..)+  , MyVariant(..)+  ) where++import Data.ByteString (ByteString)+import Data.Int++import Foreign+import Foreign.C.Types+import Foreign.CPP.HsStruct+import Foreign.CPP.HsStruct.HsOption+import Foreign.CPP.HsStruct.HsStdTuple+import Foreign.CPP.HsStruct.HsStdVariant+import Foreign.CPP.Marshallable.TH++#include <cpp/HsStdTuple.h>+#include <cpp/HsStdVariant.h>+#include <hsc.h>+#include <tests/HsStructHelper.h>++#{verbatim using facebook::common::hs::OnlyMovable;}+#{verbatim using facebook::common::hs::Nonmovable;}++data Nonmovable = Nonmovable Int ByteString+  deriving (Eq, Show)++instance Addressable Nonmovable++instance Storable Nonmovable where+  sizeOf _ = #{size HsMaybe<Nonmovable>}+  alignment _ = #{alignment HsMaybe<Nonmovable>}+  poke = error "Nonmovable: poke not implemented"+  peek p = do+    resource <- #{peek Nonmovable, resource} p+    description <- #{peek Nonmovable, description} p+    return $ Nonmovable resource $ hsByteString description++$(deriveDestructibleUnsafe "HsMaybeNonmovable" [t| HsMaybe Nonmovable |])++data OnlyMovable = OnlyMovable Int+  deriving (Eq, Show)++instance Addressable OnlyMovable++instance Storable OnlyMovable where+  sizeOf _ = #{size OnlyMovable}+  alignment _ = #{alignment OnlyMovable}+  poke p (OnlyMovable r) = #{poke OnlyMovable, r_} p r+  peek p = do+    resource <- #{peek OnlyMovable, r_} p+    return $ OnlyMovable resource+++data MyVariant+  = I Int32+  | S HsByteString+  | J (HsOption HsJSON)++-- Marshallable first+$(deriveMarshallableUnsafe "HsOptionMyCppVariant" [t| HsOption MyVariant |])+$(deriveMarshallableUnsafe "MyCppVariant" [t| MyVariant |])+$(deriveMarshallableUnsafe "CppTupleIntJSONOnlyMovable" [t| HsStdTuple (Int32, HsJSON, OnlyMovable, HsEither HsText Int) |])+$(deriveMarshallableUnsafe "TupleStringString" [t| HsStdTuple (HsText, HsText) |])+$(deriveMarshallableUnsafe "HsOptionTupleStringString" [t| HsOption (HsStdTuple (HsText, HsText)) |])++-- Constructions next+$(#{derive_hs_std_variant_unsafe MyCppVariant} "MyVariant" [t| MyVariant |])+$(#{derive_hs_option_unsafe MyCppVariant} [t| MyVariant |])+$(#{derive_hs_std_tuple_unsafe CppTupleIntJSONOnlyMovable} [t| (Int32, HsJSON, OnlyMovable, HsEither HsText Int) |])+$(#{derive_hs_std_tuple_unsafe TupleStringString} [t| (HsText, HsText) |])+$(#{derive_hs_option_unsafe TupleStringString} [t| HsStdTuple (HsText, HsText) |])
+ tests/IOBufTest.cpp view
@@ -0,0 +1,43 @@+/*+ * Copyright (c) Meta Platforms, Inc. and affiliates.+ * All rights reserved.+ *+ * This source code is licensed under the BSD-style license found in the+ * LICENSE file in the root directory of this source tree.+ */++#include <cpp/IOBuf.h>+#include <folly/io/IOBuf.h>++extern "C" {++uint8_t* echo(HS_IOBuf* hs_iobuf) noexcept {+  auto ioBuf = common::hs::newIOBufWrapping(hs_iobuf);++  auto str = ioBuf->moveToFbString();+  auto len = str.length();++  // This will get free'd by the haskell garbage collector+  auto buf = static_cast<uint8_t*>(malloc(len + 1));+  memcpy((void*)buf, (void*)str.c_str(), len);+  buf[len] = 0; // Null terminator++  return buf;+}++IOBuf* create_buffer() noexcept {+  const char* const strs[] = {+      "All happy families are alike; ",+      "every unhappy family is unhappy in its own way."};+  const int lens[] = {30, 47};+  std::unique_ptr<IOBuf> bufs[2];+  for (size_t i = 0; i < 2; i++) {+    bufs[i] = IOBuf::createCombined(50);+    strncpy((char*)bufs[i]->writableData(), strs[i], lens[i]);+    bufs[i]->append(lens[i]);+    if (i)+      bufs[0]->appendChain(std::move(bufs[i]));+  }+  return bufs[0].release();+}+}
+ tests/IOBufTest.hs view
@@ -0,0 +1,44 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module IOBufTest where++import Data.ByteString.Lazy as Lazy+import Data.ByteString.Unsafe+import Foreign.C+import Foreign.Ptr+import Util.IOBuf+import TestRunner+import Test.HUnit++lazyBS :: Lazy.ByteString+lazyBS = fromChunks ["hello", " ", "world"]++roundTripTest :: Test+roundTripTest = TestLabel "round trip" $ TestCase $ do+  bs <- unsafePackMallocCString =<< unsafeWithIOBuf lazyBS c_echo+  assertEqual "echo'd" "hello world" bs++-- `show` adds quotes+testString :: String+testString = "\"All happy families are alike; " +++ "every unhappy family is unhappy in its own way.\""++fromCTest :: Test+fromCTest = TestLabel "from C" $ TestCase $ do+  x <- toLazy c_create+  assertEqual "marshalled" testString $ show x++main :: IO ()+main = testRunner $ TestList [ roundTripTest, fromCTest ]++--------------------------------------------------------------------------------++foreign import ccall "echo"+  c_echo :: Ptr IOBuf -> IO CString+foreign import ccall unsafe "create_buffer" c_create :: Ptr IOBuf
+ tests/IOTest.hs view
@@ -0,0 +1,32 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module IOTest+  ( main+  ) where++import System.Directory+import System.FilePath+import System.IO.Temp+import TestRunner+import Test.HUnit+import Util.IO++main :: IO ()+main = testRunner $ TestList+  [ writeFileAtomicUTF8Test ]++writeFileAtomicUTF8Test :: Test+writeFileAtomicUTF8Test = TestLabel+  "creates if file and parent dir does not exist" $ TestCase $+    withSystemTempDirectory "writeFileAtomicUTF8Test" $ \tmpRoot -> do+      let+        testFile = tmpRoot </> "nested" </> "writeFileAtomicUTF8Test.tmp"+      do+        writeFileAtomicUTF8 testFile "writeFileAtomicUTF8Test"+        doesFileExist testFile >>= assertBool "File should exist"
+ tests/JSONPrettyTest.hs view
@@ -0,0 +1,41 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+module JSONPrettyTest (main) where++import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy.Char8 as B+import Compat.Prettyprinter as Pretty hiding ((<>))+import Text.JSON++import Test.HUnit+import TestRunner++import Util.JSON.Pretty ()+import Util.String.Quasi++jsonString :: String+jsonString = [s|{"byt":33,"nat":42,"array_of_byte":"eHl6AAB4ZmY","array_of_nat":[99,98],"record_":{"a":34,"b":35},"sum_":{"d":36},"named_record_":{"alpha":1,"beta":{"wed":true}},"named_sum_":{"tue":37},"named_enum_":2,"pred":{"id":3},"maybe_":{},"bool_":true,"string_":"Hello\u0000world!\u0000","null_":null}|]++jsonPrettyTest :: Test+jsonPrettyTest = TestLabel "jsonPrettyTest" $ TestCase $ do+  json <- case Text.JSON.decode jsonString of+    Error _ -> assertFailure "parse"+    Ok (v :: JSValue) -> return v+  let+    prettyJson = show $ pretty json+    Just v0 = Aeson.decode (B.pack jsonString) :: Maybe Aeson.Value+    Just v1 = Aeson.decode (B.pack prettyJson)+  assertEqual "pretty" v0 v1++main :: IO ()+main = testRunner $ TestList+  [ jsonPrettyTest+  ]
+ tests/LensTest.hs view
@@ -0,0 +1,36 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE TemplateHaskell #-}++module LensTest where++import Control.Lens+import Test.HUnit+import TestRunner+import Util.Lens++data Foo = Foo+  { foo_bar :: Int+  }++defFoo :: Foo+defFoo = Foo { foo_bar = 42 }++makeLowerCCLenses ''Foo++readTest :: Test+readTest = TestLabel "read test" $ TestCase $+  assertEqual "foo bar baz" 43 (foo_bar $ adjust defFoo)+  where+    adjust = over fooBar (+ 1)++main :: IO ()+main = testRunner $ TestList+  [ readTest+  ]
+ tests/ListTest.hs view
@@ -0,0 +1,50 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module ListTest (main) where++import Test.QuickCheck+import Test.HUnit+import TestRunner+import Util.List++main :: IO ()+main = testRunner $ TestList+  [ TestLabel "atMostChunksOf" $ TestCase $ do+      result <- quickCheckResult prop_atMostChunksOf+      case result of+        Success{} -> return ()+        _ -> assertFailure "failed"+  , TestLabel "chunkBy" $ TestCase $ do+      result <- quickCheckResult prop_chunkBy+      case result of+        Success{} -> return ()+        _ -> assertFailure "failed"+  ]++prop_atMostChunksOf :: Int -> [Int] -> Bool+prop_atMostChunksOf n xs =+  n <= 0 || null xs ||+  (  all ((<= n) . length) chunks+  && all (not . null) chunks+  && concat chunks == xs+  && length chunks <= (length xs `div` n + 1)+  )+  where+  chunks = atMostChunksOf n xs++prop_chunkBy :: Int -> [Int] -> Bool+prop_chunkBy n xs =+  n <= 0 || null xs ||+  all ok chunks && concat chunks == xs+  where+    chunks = chunkBy n id xs++    ok [] = False+    ok [_] = True+    ok ys = sum ys <= n
+ tests/MD5Test.hs view
@@ -0,0 +1,22 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module MD5Test (main) where++import Test.HUnit+import TestRunner++import Util.MD5++tests :: Test+tests = TestList+  [ TestLabel "md5Test" $ TestCase $+      assertEqual "md5Test" (md5 "wibble") "50eccc6e2b0d307d5e8a40fb296f6171" ]++main :: IO ()+main = testRunner tests
+ tests/MovingAverageRateLimiterTest.hs view
@@ -0,0 +1,91 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module MovingAverageRateLimiterTest (main) where++import Data.List+import Test.HUnit+import TestRunner++import Data.MovingAverageRateLimiter++smoothRateLimiter :: Test+smoothRateLimiter = TestList+  [ TestLabel "Smooth" $ TestCase $ assertEqual "allow 1qps" 0 fails+  , TestLabel "Smooth" $ TestCase $ assertEqual "don't allow 2qps" False+                 (fst $ allow cfg rl' (fromIntegral sz))+  ]+  where+  sz = 50 :: Int+  cfg = mkRateLimiterConfig 1.0 1.0+  rl = mkRateLimiter+  go :: (RateLimiter, Int) -> Int -> (RateLimiter, Int)+  go (r, f) now =+    let (a, r') = allow cfg r (fromIntegral now)+    in (r', f + fromEnum (not a))+  (rl', fails) = foldl' go (rl, 0) [1..sz]++nonSmoothRateLimiter :: Test+nonSmoothRateLimiter = TestList+  [ TestLabel "NonSmooth" $ TestCase $ assertEqual "allow 2qps" 0 fails+  , TestLabel "NonSmooth" $ TestCase $ assertEqual "don't allow 3qps" False+                 (fst $ allow cfg rl' (fromIntegral sz))+  ]+  where+  sz = 1000 :: Int+  cfg = mkRateLimiterConfig 2.01 10.0+  rl = mkRateLimiter+  go :: (RateLimiter, Int) -> Int -> (RateLimiter, Int)+  go (r, f) now =+    let (a1, r1) = allow cfg r (fromIntegral now)+        (a2, r2) = allow cfg r1 (fromIntegral now)+    in (r2, f + fromEnum (not a1) + fromEnum (not a2))+  (rl', fails) = foldl' go (rl, 0) [1..sz]++observedRateTest :: Test+observedRateTest = TestList+    [ TestLabel "ObservedRate" $ TestCase $+        assertEqual "don't allow at 2" False a1+    , TestLabel "ObservedRate" $ TestCase $+        assertEqual "allow at 3" True a2+    ]+  where+  cfg = mkRateLimiterConfig 1.0 1.0+  rl = mkRateLimiter+  rl2 = observedRate rl 1.01 2.0+  (a1, rl3) = allow cfg rl2 2+  (a2, _) = allow cfg rl3 3++qpsConverges :: Test+qpsConverges = TestList+  [ TestLabel "constant" $ TestCase $ convergeTest 1.0 600.0 86400.0+      [ 0.0, 0.1 .. 86400.0 ]+  , TestLabel "skip6hours" $ TestCase $ convergeTest 2.0 60.0 129600.0 $+      [ 0.0, 0.1 .. 21600.0] ++ [ 43200.0, 43200.1 .. 86400 ]+  ]++convergeTest :: Double -> Double -> Double -> [Double] -> Assertion+convergeTest qps0 hl expected bumps = do+  putStrLn $ "Expected QPS: " ++ show expected+  putStrLn $ "Got: " ++ show count+  assertBool "converges on expected rate" closeEnough+  where+    cfg = mkRateLimiterConfig qps0 hl+    go (r, n) t =+      let (a, r') = allow cfg r t+      in (r', n + fromEnum a)+    (_, count) = foldl' go (mkRateLimiter, 0 :: Int) bumps+    closeEnough = abs (fromIntegral count - expected) / expected < 0.01++main :: IO ()+main = testRunner $ TestList+  [ smoothRateLimiter+  , nonSmoothRateLimiter+  , observedRateTest+  , qpsConverges+  ]
+ tests/OptParseTest.hs view
@@ -0,0 +1,70 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module OptParseTest where++import Test.HUnit+import TestRunner++import Data.Text (Text)+import Facebook.Init+import Options.Applicative+import Util.OptParse++data Options = Options+  { foo :: Text+  , bar :: Int+  }++optionsParser :: Parser Options+optionsParser = Options+  <$> textOption+    ( long "foo" <> metavar "FOO" <> help "foo" )+  <*> intOption+    ( long "bar" <> value 42 <>  metavar "BAR" <> help "bar" )++optsInfo :: ParserInfo Options+optsInfo = info (helper <*> optionsParser) fullDesc++partialTest :: Test+partialTest = TestLabel "partial" $ TestCase $ do+  doTest -- only defined flags+    [ "--foo=foo", "--bar=7" ]+    []++  doTest -- start with an unknown+    [ "--baz=5", "--foo=foo", "--bar=7" ]+    [ "--baz=5" ]++  doTest -- unknown in the middle+    [ "--foo=foo", "--baz=5", "--bar=7" ]+    [ "--baz=5" ]++  doTest -- end with an unknown+    [ "--foo=foo", "--bar=7", "--baz=5" ]+    [ "--baz=5" ]++  doTest -- intercalate known and unknown+    [ "--snert=4", "--foo=foo", "--quux=wat", "--bar=7", "--baz=5" ]+    [ "--snert=4", "--quux=wat", "--baz=5"]++  doTest -- `--`+    [ "--foo=foo", "--baz=5", "--", "--bar=7", "--" ]+    [ "--baz=5", "--bar=7", "--" ]++  where+    doTest inp ex = do+      (_, args) <- partialParse defaultPrefs optsInfo inp+      assertEqual (show inp) ex args+++main :: IO ()+main = withFacebookUnitTest $+  testRunner $ TestList+    [ partialTest+    ]
+ tests/RWVarTest.hs view
@@ -0,0 +1,82 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module RWVarTest (main) where++import Test.HUnit+import TestRunner++import Facebook.Init+import Util.RWVar+import Util.HUnit++readTest :: Test+readTest = TestLabel "readTest" $ TestCase $ do+  var <- newRWVar expected+  withReadRWVar var $ \v ->+    assertEqual "got expected back" expected v+  where+    expected = 'a'++writeTest :: Test+writeTest = TestLabel "writeTest" $ TestCase $ do+  var <- newRWVar initial+  withWriteRWVar var $ \v -> do+    assertEqual "got initial" initial v+    return (update, ())+  withReadRWVar var $ \v ->+    assertEqual "got updated value" update v+  where+    initial :: Int+    initial = 42+    update = 1337++readReadTest :: Test+readReadTest = TestLabel "nestedReads" $ TestCase $ do+  var <- newRWVar val+  withReadRWVar var $ \x -> do+    assertEqual "first got value" val x+    withReadRWVar var $ \y ->+      assertEqual "second got value" val y+  where+    val = 'a'++readWriteDeadlockTest :: Test+readWriteDeadlockTest = TestLabel "read then write deadlocks" $ TestCase $ do+  var <- newRWVar 'a'+  assertThrow "deadlocks" $+    withReadRWVar var $ \_ ->+      withWriteRWVar var $ \a -> return (a, ())++writeReadDeadlockTest :: Test+writeReadDeadlockTest = TestLabel "write then read deadlocks" $ TestCase $ do+  var <- newRWVar 'a'+  assertThrow "deadlocks" $+    withWriteRWVar var $ \a -> do+      _ <- withReadRWVar var return+      return (a, ())++writeWriteDeadlockTest :: Test+writeWriteDeadlockTest = TestLabel "write then write deadlocks" $ TestCase $ do+  var <- newRWVar 'a'+  assertThrow "deadlocks" $+    withWriteRWVar var $ \x -> do+      _ <- withWriteRWVar var $ \y -> return (y, ())+      return (x, ())+++main :: IO ()+main = withFacebookUnitTest $+  testRunner $ TestList+   [ readTest+   , writeTest+   , readReadTest+   , readWriteDeadlockTest+   , writeReadDeadlockTest+   , writeWriteDeadlockTest+   ]
+ tests/RateLimiterMapTest.hs view
@@ -0,0 +1,69 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module RateLimiterMapTest where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Monad++import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Text (Text, copy)++import Data.RateLimiterMap++import Test.HUnit+import TestRunner++rlTest :: Assertion+rlTest = do+  let reduceM z xs f = foldM f z xs++  crl <- newRateLimiterMapWithKeyPreprocessor 1 1 (return . copy)+  -- 500 reqs to "foo" with 10 millisecond delay (100 qps for 5 secs)+  (fooCount, _) <-+    reduceM (0::Int, 0) [1..500] $ \ acc@(c,w) i -> do+      threadDelay (10^(4::Int)) -- 10 milliseconds+      allowed <- isAllowed crl "foo"+      case allowed of+        NotAllowed -> return acc+        Allowed sw -> do+          assertEqual "weight sum counts all" i (sw+w)+          return (c+1, sw+w)+  assertBool "was actually allowed" (fooCount > 0)+  assertBool "was actually limited" (fooCount < 20)++rlThreadedTest :: Assertion+rlThreadedTest = do+  crl <- newRateLimiterMap 5 5 :: IO (RateLimiterMap Text)+  mv <- newMVar (mempty :: HashMap Text (Int, SampleWeight))+  -- 50k reqs each to "foo" and "bar" from 100k threads,+  -- requests come in bursts every quarter second for 5 secs+  -- a test with 100k threads? sure why not+  forConcurrently_ (zip [1..100000] $ cycle ["foo", "bar"]) $ \ (i, nm) -> do+    threadDelay ((i `mod` 20) * 25 * 10^(4::Int))+    allowed <- isAllowed crl nm+    case allowed of+      NotAllowed -> return ()+      Allowed sw ->+        modifyMVar_ mv $+          return . HashMap.insertWith (\(c',w') (c,w) -> (c+c', w+w')) nm (1,sw)+  m <- takeMVar mv+  let (fooCount,_) = HashMap.lookupDefault (0,0) "foo" m+      (barCount,_) = HashMap.lookupDefault (0,0) "bar" m+  assertBool "foo was allowed" (fooCount > 0)+  assertBool "bar was allowed" (barCount > 0)+  assertBool "foo was limited" (fooCount < 100)+  assertBool "bar was limited" (barCount < 100)++main :: IO ()+main = testRunner $ TestList+  [ TestLabel "RateLimiterMap" $ TestCase rlTest+  , TestLabel "RateLimiterMapThreads" $ TestCase rlThreadedTest+  ]
+ tests/StreamTest.hs view
@@ -0,0 +1,70 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module StreamTest (main) where++import Control.Concurrent+import Data.IORef+import Test.HUnit+import TestRunner++import Facebook.Init+import Util.TimeSec++import Control.Concurrent.Stream+import Data.List++-- Run a worker that sleeps for 1 second over 10 elements.+-- Using 5 workers means we should finish in less than 10 seconds.+timingTest :: Bool -> Test+timingTest bound = TestLabel "timing" $ TestCase $ do+  s <- now+  count <- newIORef (0::Int)+  let+    producer add = mapM_ add [1..(10::Int)]+    sleepy _ = do threadDelay 1000000; atomicModifyIORef' count (\i -> (i+1,()))+  (if bound then streamBound else stream) 5 producer sleepy+  e <- now+  let (TimeSpan d) = timeDiff e s+  assertBool "faster than sequential" (d < 5)+  final <- readIORef count+  assertEqual "all done" 10 final++testMapConcurrently_unordered :: Test+testMapConcurrently_unordered =+  TestLabel "mapConcurrently_unordered" $ TestCase $ do+    let input = [0..9]+    let expected = [1..10]+    startTime <- now+    output <- mapConcurrently_unordered+      10 (\x -> do threadDelay 1000000; pure (x + 1 :: Int)) input+    endTime <- now+    assertBool "Is faster than sequential"+      (toSeconds (timeDiff endTime startTime) < 10)+    assertBool "Received the expected output"+      (expected == sort output)++testMapForConcurrentlyEquivalent_unordered :: Test+testMapForConcurrentlyEquivalent_unordered =+  TestLabel+    "mapConcurrently_unordered==forConcurrently_unordered" $ TestCase $ do+      let input = [0..9]+      mapOut <- mapConcurrently_unordered 10 (\x -> pure $ x + (1 :: Int)) input+      forOut <- forConcurrently_unordered 10 input (\x -> pure $ x + (1 :: Int))+      assertBool+        "mapConcurrently_unordered and forConcurrently_unordered are equivalent"+        (sort mapOut == sort forOut)+++main :: IO ()+main = withFacebookUnitTest $ testRunner $ TestList+  [ timingTest True+  , timingTest False+  , testMapConcurrently_unordered+  , testMapForConcurrentlyEquivalent_unordered+  ]
+ tests/StringQuasiTest.hs view
@@ -0,0 +1,26 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE QuasiQuotes #-}+module StringQuasiTest (main) where++import Data.List++import Test.HUnit+import TestRunner++import Util.String.Quasi++main :: IO ()+main = testRunner $ TestList+  [ TestLabel "util-string-quasi" . TestCase $ do+      let str = [s|+this is a+multi-line string literal with \no escaping\|]+      assertBool "util-string-quasi" ("\\no escaping\\" `isSuffixOf` str)+  ]
+ tests/THTest.hs view
@@ -0,0 +1,24 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE TemplateHaskell #-}++module THTest (main) where++import Test.HUnit+import TestRunner+import Language.Haskell.TH+import Util.MD5++tests :: Test+tests = TestList+  [ TestLabel "th test" $ TestCase $+      assertEqual "th test" (md5 "dupa") $(runQ [| md5 "dupa" |]) ]++main :: IO ()+main = testRunner tests
+ tests/TimeSecTest.hs view
@@ -0,0 +1,27 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module TimeSecTest (main) where++import Test.HUnit+import TestRunner++import Data.Aeson++import Util.TimeSec++jsonTest :: Test+jsonTest = TestLabel "Aeson instances" $ TestCase $ do+  assertEqual "toJSON" (Number 123) (toJSON $ Time 123)+  assertEqual "fromJSON" (eitherDecode "123")+    (timeInSeconds <$> eitherDecode "123")++main :: IO ()+main = testRunner $ TestList+  [ jsonTest+  ]
+ tests/ToExpTest.hs view
@@ -0,0 +1,60 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE CPP #-}+module ToExpTest where++import Test.HUnit+import TestRunner++import Data.Aeson ((.=), Value(Array, Number, Bool), object)+import qualified Data.Aeson as A+import Data.List+import qualified Data.Vector as Vector+import Util.ToExp++tests :: Test+tests = TestList+  [ TestLabel "numbers" $ TestCase $ do+      assertEqual "int"+        "3"+        (pp (3 :: Int))+      assertEqual "negative int"+        "(-7)"+        (pp (-7 :: Int))+      assertEqual "negative double"+        "(-7.0)"+        (pp (-7.0 :: Double))+      assertEqual "negative number in "+        "Just (-7)"+        (pp (Just (-7) :: Maybe Int))+  , TestLabel "json" $ TestCase $ do+      assertEqual "array"+        "Array (Vector.fromList [Number (-3), Bool True, String \"foobarbaz\"])"+        (pp $ Array $ Vector.fromList+          [ Number (-3)+          , Bool True+          , A.String "foobarbaz"+          ])+      assertEqual "object"+        -- the result is non-deterministic. Rather than add the+        -- overhead of sorting the elements all the time, let's just+        -- sort the test output.+#if MIN_VERSION_aeson(2,0,0)+        (sort "Object (fromList [(fromText \"foo\", Number (-3)), (fromText \"bar\", Bool True)])")+#else+        (sort "Object (HashMap.fromList [(\"foo\", Number (-3)), (\"bar\", Bool True)])")+#endif+        (sort $ pp $ object+          [ "foo" .= Number (-3)+          , "bar" .= Bool True+          ])+  ]++main :: IO ()+main = testRunner tests
+ tests/UnitTests.hs view
@@ -0,0 +1,120 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE CPP #-}+module UnitTests (main) where++import Test.HUnit+import TestRunner++import Util.ByteString+import Util.Aeson+import qualified Util.Text as UT+import Data.Aeson.Types+import Data.Aeson (decode)+import Data.ByteString (packCString, packCStringLen, ByteString)++import Foreign.Storable+import Foreign.C.String+import Foreign.C.Types+import Foreign.Marshal.Array (advancePtr)+import Foreign.Ptr (nullPtr, Ptr)++import TextShow++intToByteStringTest :: Test+intToByteStringTest = TestCase $ do+  assertEqual "min int" (intToByteString minBound) "-9223372036854775808"+  assertEqual "max int" (intToByteString maxBound) "9223372036854775807"+  assertEqual "zero" (intToByteString 0) "0"++parseValueStrictTest :: Test+parseValueStrictTest = TestCase $ do+  assertEqual "false" (Right $ Bool False) $ parseValueStrict' "false"+  assertEqual "0.1" (Right $ Number 0.1) $ parseValueStrict' "0.1"+  assertEqual "consume all input" (Left "endOfInput") $+    parseValueStrict' "falsee"++#ifdef FACEBOOK+-- | We've patched the official aeson library to handle NaN. See #5183005+-- This test ensures that we notice if we forget to patch on upgrade.+parseNaN :: Test+parseNaN = TestCase $+  case decode "[NaN]" of+    Just [a :: Double] ->+      assertBool "NaN" $ isNaN a+    _ -> assertFailure "couldn't parse NaN"+#endif++withCStringLenTest :: Test+withCStringLenTest = TestCase $+  UT.withCStringLen "Hello World" $ \(ptr, _) -> do+    val <- peek ptr+    assertEqual "first character" val (castCharToCChar 'H')++useByteStringsAsCStringsTest :: Test+useByteStringsAsCStringsTest = TestCase $+  useByteStringsAsCStrings ["hello", "world"] $ \ptr -> do+    hello <- packCString =<< peek ptr+    world <- packCString =<< peek (advancePtr ptr 1)+    term <- peek $ advancePtr ptr 2+    assertEqual "first word" hello "hello"+    assertEqual "second word" world "world"+    assertEqual "terminator" term nullPtr++-- This should probably be a QuickCheck Property+bsListAsCStrLenArrTest :: [ByteString] -> Test+bsListAsCStrLenArrTest bs = TestCase $+  bsListAsCStrLenArr bs $ \strPtr lenPtr len -> do+    let packBS :: CSize -> IO ByteString+        packBS i = packCStringLen =<< (,)+                   <$> peek (getPtr strPtr)+                   <*> (fromIntegral <$> peek (getPtr lenPtr))+            where getPtr :: Storable a => Ptr a -> Ptr a+                  getPtr = (`advancePtr` fromIntegral i)+    got <- mapM packBS [0..len - 1]+    assertEqual "same list" got bs++data MyEnum = MyA | MyB+  deriving (Bounded, Enum, Eq, Show)++instance UT.TextRead MyEnum+instance TextShow MyEnum where+  showb MyA = "MyA"+  showb MyB = "MyB"++readTextTest :: Test+readTextTest = TestCase $ do+  assertEqual "myA" (Just MyA) (UT.readText "MyA")+  assertEqual "Nothing" (Nothing :: Maybe MyEnum) (UT.readText "MyC")++insertCommasAndAndTest :: Test+insertCommasAndAndTest = TestCase $ do+  assertEqual "null" "" $ UT.insertCommasAndAnd []+  assertEqual "singleton" "foo" $ UT.insertCommasAndAnd ["foo"]+  assertEqual "pair" "foo and bar" $ UT.insertCommasAndAnd ["foo", "bar"]+  assertEqual "triple" "foo, bar, and baz" $+    UT.insertCommasAndAnd ["foo", "bar", "baz"]+  assertEqual "quad" "foo, bar, baz, and quux" $+    UT.insertCommasAndAnd ["foo", "bar", "baz", "quux"]+  assertEqual "10" "1, 2, 3, 4, 5, 6, 7, 8, 9, and 10" $+    UT.insertCommasAndAnd [ showt (i::Int) | i <- [1..10] ]++main :: IO ()+main = testRunner $ TestList+  [ TestLabel "intToByteString" intToByteStringTest+  , TestLabel "parseValueStrictTest" parseValueStrictTest+#ifdef FACEBOOK+  , TestLabel "parseNaN" parseNaN+#endif+  , TestLabel "withCStringLen" withCStringLenTest+  , TestLabel "useByteStringsAsCStrings" useByteStringsAsCStringsTest+  , TestLabel "bsListAsCStrLenArr" (bsListAsCStrLenArrTest ["hello", "world"])+  , TestLabel "readText" readTextTest+  , TestLabel "insertCommasAndAnd" insertCommasAndAndTest+  ]
+ tests/github/SpecRunner.hs view
@@ -0,0 +1,14 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module SpecRunner where++import Test.Hspec++specRunner :: Spec -> IO ()+specRunner = hspec