replace ‘text-format’ with ‘formatting’

The former seems unmaintained, and I really should have checked this before doing the initial work

accelerate.cabal

@@ -296,6 +296,7 @@ library
         , directory                     >= 1.0
         , exceptions                    >= 0.6
         , filepath                      >= 1.0
+        , formatting                    >= 6.3
         , ghc-prim
         , half                          >= 0.3
         , hashable                      >= 1.1
@@ -310,7 +311,6 @@ library
         , template-haskell
         , terminal-size                 >= 0.3
         , text                          >= 1.2.4
-        , text-format                   >= 0.3
         , transformers                  >= 0.3
         , unique
         , unordered-containers          >= 0.2
@@ -438,7 +438,6 @@ library
         Data.Array.Accelerate.Test.NoFib.Base
         Data.Array.Accelerate.Test.NoFib.Config
 
-        Data.Text.Format.Extra
         Language.Haskell.TH.Extra
 
   if flag(nofib)

src/Data/Array/Accelerate/AST.hs

@@ -153,12 +153,10 @@ import Control.DeepSeq
 import Data.Kind
 import Data.Maybe
 import Data.Text                                                    ( Text )
-import Data.Text.Format
 import Data.Text.Lazy.Builder
-import Data.Text.Lazy.Builder.Int
+import Formatting
 import Language.Haskell.TH                                          ( Q, TExp )
 import qualified Language.Haskell.TH.Syntax                         as TH
-import Prelude
 
 import GHC.TypeLits
 
@@ -870,13 +868,13 @@ primFunType = \case
   PrimBOr t                 -> binary' $ integral t
   PrimBXor t                -> binary' $ integral t
   PrimBNot t                -> unary' $ integral t
-  PrimBShiftL t             -> (integral t `TupRpair` int, integral t)
-  PrimBShiftR t             -> (integral t `TupRpair` int, integral t)
-  PrimBRotateL t            -> (integral t `TupRpair` int, integral t)
-  PrimBRotateR t            -> (integral t `TupRpair` int, integral t)
-  PrimPopCount t            -> unary (integral t) int
-  PrimCountLeadingZeros t   -> unary (integral t) int
-  PrimCountTrailingZeros t  -> unary (integral t) int
+  PrimBShiftL t             -> (integral t `TupRpair` tint, integral t)
+  PrimBShiftR t             -> (integral t `TupRpair` tint, integral t)
+  PrimBRotateL t            -> (integral t `TupRpair` tint, integral t)
+  PrimBRotateR t            -> (integral t `TupRpair` tint, integral t)
+  PrimPopCount t            -> unary (integral t) tint
+  PrimCountLeadingZeros t   -> unary (integral t) tint
+  PrimCountTrailingZeros t  -> unary (integral t) tint
 
   -- Fractional, Floating
   PrimFDiv t                -> binary' $ floating t
@@ -907,8 +905,8 @@ primFunType = \case
 
   -- RealFloat
   PrimAtan2 t               -> binary' $ floating t
-  PrimIsNaN t               -> unary (floating t) bool
-  PrimIsInfinite t          -> unary (floating t) bool
+  PrimIsNaN t               -> unary (floating t) tbool
+  PrimIsInfinite t          -> unary (floating t) tbool
 
   -- Relational and equality
   PrimLt t                  -> compare' t
@@ -921,9 +919,9 @@ primFunType = \case
   PrimMin t                 -> binary' $ single t
 
   -- Logical
-  PrimLAnd                  -> binary' bool
-  PrimLOr                   -> binary' bool
-  PrimLNot                  -> unary' bool
+  PrimLAnd                  -> binary' tbool
+  PrimLOr                   -> binary' tbool
+  PrimLNot                  -> unary' tbool
 
   -- general conversion between types
   PrimFromIntegral a b      -> unary (integral a) (num b)
@@ -934,15 +932,15 @@ primFunType = \case
     unary' a   = unary a a
     binary a b = (a `TupRpair` a, b)
     binary' a  = binary a a
-    compare' a = binary (single a) bool
+    compare' a = binary (single a) tbool
 
     single   = TupRsingle . SingleScalarType
     num      = TupRsingle . SingleScalarType . NumSingleType
     integral = num . IntegralNumType
     floating = num . FloatingNumType
 
-    bool     = TupRsingle scalarTypeWord8
-    int      = TupRsingle scalarTypeInt
+    tbool    = TupRsingle scalarTypeWord8
+    tint     = TupRsingle scalarTypeInt
 
 
 -- Normal form data
@@ -1398,8 +1396,8 @@ liftPrimFun (PrimToFloating ta tb)     = [|| PrimToFloating $$(liftNumType ta) $
 
 showPreAccOp :: forall acc aenv arrs. PreOpenAcc acc aenv arrs -> Builder
 showPreAccOp Alet{}              = "Alet"
-showPreAccOp (Avar (Var _ ix))   = build "Avar a{}" (Only (decimal (idxToInt ix)))
-showPreAccOp (Use aR a)          = build "Use {}" (showArrayShort 5 (showsElt (arrayRtype aR)) aR a)
+showPreAccOp (Avar (Var _ ix))   = bformat ("Avar a" % int) (idxToInt ix)
+showPreAccOp (Use aR a)          = bformat ("Use " % string) (showArrayShort 5 (showsElt (arrayRtype aR)) aR a)
 showPreAccOp Atrace{}            = "Atrace"
 showPreAccOp Apply{}             = "Apply"
 showPreAccOp Aforeign{}          = "Aforeign"
@@ -1430,8 +1428,8 @@ showDirection RightToLeft = singleton 'r'
 
 showExpOp :: forall aenv env t. OpenExp aenv env t -> Builder
 showExpOp Let{}             = "Let"
-showExpOp (Evar (Var _ ix)) = build "Var x{}" (Only (decimal (idxToInt ix)))
-showExpOp (Const tp c)      = build "Const {}" (showElt (TupRsingle tp) c)
+showExpOp (Evar (Var _ ix)) = bformat ("Var x" % int) (idxToInt ix)
+showExpOp (Const tp c)      = bformat ("Const " % string) (showElt (TupRsingle tp) c)
 showExpOp Undef{}           = "Undef"
 showExpOp Foreign{}         = "Foreign"
 showExpOp Pair{}            = "Pair"

src/Data/Array/Accelerate/Array/Data.hs

@@ -64,17 +64,16 @@ import Data.Array.Accelerate.Debug.Internal.Flags
 import Data.Array.Accelerate.Debug.Internal.Profile
 import Data.Array.Accelerate.Debug.Internal.Trace
 
-
 -- standard libraries
 import Control.Applicative
 import Control.DeepSeq
 import Control.Monad                                                ( (<=<) )
 import Data.Bits
 import Data.IORef
 import Data.Primitive                                               ( sizeOf# )
-import Data.Text.Format
 import Foreign.ForeignPtr
 import Foreign.Storable
+import Formatting                                                   hiding ( bytes )
 import Language.Haskell.TH                                          hiding ( Type )
 import System.IO.Unsafe
 import Prelude                                                      hiding ( mapM )
@@ -290,7 +289,7 @@ allocateArray !size = internalCheck "size must be >= 0" (size >= 0) $ do
            let bytes = size * sizeOf (undefined :: e)
            new <- readIORef __mallocForeignPtrBytes
            ptr <- new bytes
-           traceIO dump_gc $ build "gc: allocated new host array (size={}, ptr={})" (bytes, unsafeForeignPtrToPtr ptr)
+           traceIO dump_gc $ bformat ("gc: allocated new host array (size=" % int % ", ptr=" % build % ")") bytes (unsafeForeignPtrToPtr ptr)
            local_memory_alloc (unsafeForeignPtrToPtr ptr) bytes
            return (castForeignPtr ptr)
 #ifdef ACCELERATE_DEBUG

src/Data/Array/Accelerate/Array/Remote/LRU.hs

@@ -57,12 +57,12 @@ import Control.Monad.Catch
 import Control.Monad.IO.Class                                       ( MonadIO, liftIO )
 import Data.Functor
 import Data.Maybe                                                   ( isNothing )
-import Data.Text.Format
 import Data.Text.Lazy.Builder                                       ( Builder )
+import Formatting
 import System.CPUTime
 import System.Mem.Weak                                              ( Weak, deRefWeak, finalize )
-import Prelude                                                      hiding ( lookup )
 import qualified Data.HashTable.IO                                  as HT
+import Prelude                                                      hiding ( lookup )
 
 import GHC.Stack
 
@@ -155,7 +155,7 @@ withRemote (MemoryTable !mt !ref _) !tp !arr run | SingleArrayDict <- singleArra
     --
     case mu of
       Nothing -> do
-        message (build "withRemote/array has never been malloc'd: {}" (Only key))
+        message (bformat ("withRemote/array has never been malloc'd: " % build) key)
         return Nothing -- The array was never in the table
 
       Just u  -> do
@@ -164,7 +164,7 @@ withRemote (MemoryTable !mt !ref _) !tp !arr run | SingleArrayDict <- singleArra
                 Just p          -> return p
                 Nothing
                   | isEvicted u -> copyBack utbl (incCount u)
-                  | otherwise   -> do message (build "lost array {}" (Only key))
+                  | otherwise   -> do message (bformat ("lost array " % build) key)
                                       internalError "non-evicted array has been lost"
         return (Just ptr)
   --
@@ -196,7 +196,7 @@ withRemote (MemoryTable !mt !ref _) !tp !arr run | SingleArrayDict <- singleArra
        -> RemotePtr m (ScalarArrayDataR a)
        -> m c
     go key ptr = do
-      message (build "withRemote/using: " (Only key))
+      message (bformat ("withRemote/using: " % build) key)
       (task, c) <- run ptr
       liftIO . withMVar ref  $ \utbl -> do
         HT.mutateIO utbl key $ \case
@@ -296,7 +296,7 @@ evictLRU !utbl !mt = trace "evictLRU/evicting-eldest-array" $ do
           message "evictLRU/Accelerate GC interrupted by GHC GC"
 
         Just arr -> do
-          message (build "evictLRU/evicting {}" (Only sa))
+          message (bformat ("evictLRU/evicting " % build) sa)
           copyIfNecessary status n tp arr
           -- liftIO $ Debug.remote_memory_evict sa (remoteBytes tp n)
           liftIO $ Basic.freeStable @m mt sa
@@ -386,7 +386,7 @@ finalizer !key !weak_utbl = do
   mref <- deRefWeak weak_utbl
   case mref of
     Nothing  -> message "finalize cache/dead table"
-    Just ref -> trace  (build "finalize cache: {}" (Only key)) $ withMVar' ref (`delete` key)
+    Just ref -> trace (bformat ("finalize cache: " % build) key) $ withMVar' ref (`delete` key)
 
 delete :: UT task -> StableArray -> IO ()
 delete = HT.delete

src/Data/Array/Accelerate/Array/Remote/Table.hs

@@ -47,15 +47,15 @@ import Control.Monad.IO.Class                                       ( MonadIO, l
 import Data.Functor
 import Data.Hashable                                                ( hash, Hashable )
 import Data.Maybe                                                   ( isJust )
-import Data.Word
-import Data.Text.Format
 import Data.Text.Lazy.Builder                                       ( Builder )
+import Data.Word
 import Foreign.Storable                                             ( sizeOf )
+import Formatting
+import Prelude                                                      hiding ( lookup, id )
 import System.Mem                                                   ( performGC )
 import System.Mem.Weak                                              ( Weak, deRefWeak )
-import Prelude                                                      hiding ( lookup, id )
 import qualified Data.HashTable.IO                                  as HT
-import qualified Data.Text.Buildable                                as T
+import qualified Formatting.Buildable                               as F
 
 import Data.Array.Accelerate.Array.Data
 import Data.Array.Accelerate.Array.Remote.Class
@@ -106,8 +106,8 @@ newtype StableArray = StableArray Unique
 instance Show StableArray where
   show (StableArray u) = show (hash u)
 
-instance T.Buildable StableArray where
-  build (StableArray u) = T.build (hash u)
+instance F.Buildable StableArray where
+  build (StableArray u) = F.build (hash u)
 
 -- | Create a new memory table from host to remote arrays.
 --
@@ -138,11 +138,11 @@ lookup (MemoryTable !ref _ _ _) !tp !arr
     sa <- makeStableArray tp arr
     mw <- withMVar ref (`HT.lookup` sa)
     case mw of
-      Nothing                  -> trace (build "lookup/not found: {}" (Only sa)) $ return Nothing
+      Nothing                  -> trace (bformat ("lookup/not found: " % build) sa) $ return Nothing
       Just (RemoteArray p _ w) -> do
         mv <- deRefWeak w
         case mv of
-          Just{} -> trace (build "lookup/found: {}" (Only sa)) $ return (Just $ castRemotePtr @m p)
+          Just{} -> trace (bformat ("lookup/found: " % build) sa) $ return (Just $ castRemotePtr @m p)
 
           -- Note: [Weak pointer weirdness]
           --
@@ -157,7 +157,7 @@ lookup (MemoryTable !ref _ _ _) !tp !arr
           -- above in the error message.
           --
           Nothing ->
-            makeStableArray tp arr >>= \x -> internalError $ build "dead weak pair: {}" (Only x)
+            makeStableArray tp arr >>= \x -> internalError $ bformat ("dead weak pair: " % build) x
 
 -- | Allocate a new device array to be associated with the given host-side array.
 -- This may not always use the `malloc` provided by the `RemoteMemory` instance.
@@ -184,28 +184,33 @@ malloc mt@(MemoryTable _ _ !nursery _) !tp !ad !n
     --
     chunk <- remoteAllocationSize
     let -- next highest multiple of f from x
-        multiple x f      = (x + (f-1)) `quot` f
-        bytes             = chunk * multiple (n * sizeOf (undefined::(ScalarArrayDataR a))) chunk
+        multiple x f  = (x + (f-1)) `quot` f
+        bs            = chunk * multiple (n * sizeOf (undefined::(ScalarArrayDataR a))) chunk
     --
-    message $ build "malloc {} bytes ({} x {} bytes, type={}, pagesize={})" (bytes, n, sizeOf (undefined :: (ScalarArrayDataR a)), tp, chunk)
+    message $ bformat ("malloc " % int % " bytes (" % int % " x " % int % " bytes, type=" % build % ", pagesize=" % int % ")")
+                bs
+                n
+                (sizeOf (undefined :: (ScalarArrayDataR a)))
+                tp
+                chunk
     --
     mp <-
       fmap (castRemotePtr @m)
-      <$> attempt "malloc/nursery" (liftIO $ N.lookup bytes nursery)
+      <$> attempt "malloc/nursery" (liftIO $ N.lookup bs nursery)
           `orElse`
-          attempt "malloc/new" (mallocRemote bytes)
+          attempt "malloc/new" (mallocRemote bs)
           `orElse` do message "malloc/remote-malloc-failed (cleaning)"
                       clean mt
-                      liftIO $ N.lookup bytes nursery
+                      liftIO $ N.lookup bs nursery
           `orElse` do message "malloc/remote-malloc-failed (purging)"
                       purge mt
-                      mallocRemote bytes
+                      mallocRemote bs
           `orElse` do message "malloc/remote-malloc-failed (non-recoverable)"
                       return Nothing
     case mp of
       Nothing -> return Nothing
       Just p' -> do
-        insert mt tp ad p' bytes
+        insert mt tp ad p' bs
         return mp
   where
     {-# INLINE orElse #-}
@@ -252,11 +257,11 @@ freeStable (MemoryTable !ref _ !nrs _) !sa =
   HT.mutateIO mt sa $ \mw -> do
     case mw of
       Nothing ->
-        message (build "free/already-removed: {}" (Only sa))
+        message (bformat ("free/already-removed: " % build) sa)
 
-      Just (RemoteArray !p !bytes _) -> do
-        message (build "free/nursery: {} of {}" (sa, showBytes bytes))
-        N.insert bytes (castRemotePtr @m p) nrs
+      Just (RemoteArray !p !n _) -> do
+        message (bformat ("free/nursery: " % build % " of " % bytes') sa n)
+        N.insert n (castRemotePtr @m p) nrs
         -- Debug.remote_memory_free (unsafeRemotePtrToPtr @m p)
 
     return (Nothing, ())
@@ -274,12 +279,12 @@ insert
     -> RemotePtr m (ScalarArrayDataR a)
     -> Int
     -> m ()
-insert mt@(MemoryTable !ref _ _ _) !tp !arr !ptr !bytes | SingleArrayDict <- singleArrayDict tp = do
+insert mt@(MemoryTable !ref _ _ _) !tp !arr !ptr !n | SingleArrayDict <- singleArrayDict tp = do
   key  <- makeStableArray tp arr
   weak <- liftIO $ makeWeakArrayData tp arr () (Just $ freeStable @m mt key)
-  message $ build "insert: {}" (Only key)
-  -- liftIO  $ Debug.remote_memory_alloc (unsafeRemotePtrToPtr @m ptr) bytes
-  liftIO  $ withMVar ref $ \tbl -> HT.insert tbl key (RemoteArray (castRemotePtr @m ptr) bytes weak)
+  message $ bformat ("insert: " % build) key
+  -- liftIO  $ Debug.remote_memory_alloc (unsafeRemotePtrToPtr @m ptr) n
+  liftIO  $ withMVar ref $ \tbl -> HT.insert tbl key (RemoteArray (castRemotePtr @m ptr) n weak)
 
 
 -- | Record an association between a host-side array and a remote memory area
@@ -298,7 +303,7 @@ insertUnmanaged
 insertUnmanaged (MemoryTable !ref !weak_ref _ _) tp !arr !ptr | SingleArrayDict  <- singleArrayDict tp = do
   key  <- makeStableArray tp arr
   weak <- liftIO $ makeWeakArrayData tp arr () (Just $ remoteFinalizer weak_ref key)
-  message $ build "insertUnmanaged: {}" (Only key)
+  message $ bformat ("insertUnmanaged: " % build) key
   liftIO  $ withMVar ref $ \tbl -> HT.insert tbl key (RemoteArray (castRemotePtr @m ptr) 0 weak)
 
 
@@ -352,8 +357,8 @@ remoteFinalizer :: Weak (MT p) -> StableArray -> IO ()
 remoteFinalizer !weak_ref !key = do
   mr <- deRefWeak weak_ref
   case mr of
-    Nothing  -> message (build "finalise/dead table: {}" (Only key))
-    Just ref -> trace   (build "finalise: {}"            (Only key)) $ withMVar ref (`HT.delete` key)
+    Nothing  -> message (bformat ("finalise/dead table: " % build) key)
+    Just ref -> trace   (bformat ("finalise: " % build)            key) $ withMVar ref (`HT.delete` key)
 
 
 -- Miscellaneous
@@ -396,9 +401,9 @@ makeWeakArrayData !tp !ad !c !mf | SingleArrayDict <- singleArrayDict tp = do
 -- Debug
 -- -----
 
-{-# INLINE showBytes #-}
-showBytes :: Integral n => n -> Builder
-showBytes x = Debug.showFFloatSIBase (Just 0) 1024 (fromIntegral x :: Double) "B"
+{-# INLINE bytes' #-}
+bytes' :: Integral n => Format r (n -> r)
+bytes' = bytes (fixed @Double 2 % " ")
 
 {-# INLINE trace #-}
 trace :: MonadIO m => Builder -> m a -> m a
@@ -420,12 +425,12 @@ management msg nrs next = do
       r           <- next
       after       <- availableRemoteMem
       after_nrs   <- liftIO $ N.size nrs
-      message $ build "{} (freed: {}, stashed: {}, remaining: {} of {})"
-                  ( msg
-                  , showBytes (before - after)
-                  , showBytes (after_nrs - before_nrs)
-                  , showBytes after
-                  , showBytes total )
+      message $ bformat (builder % parenthesised ("freed: " % bytes' % ", stashed: " % bytes' % ", remaining: " % bytes' % " of " % bytes'))
+                  msg
+                  (before - after)
+                  (after_nrs - before_nrs)
+                  after
+                  total
       --
       return r
     else