feat(Internal): add Scoped (codensity) (#167)

An implementation of `Codensity` called `Scoped` to clean up
nested CPS code along with some common `Foreign.*` functions wrapped
in `Scoped`.

Author: jhenahan

cabal.project

@@ -5,9 +5,12 @@ packages:
 package libsodium-bindings
   ghc-options: -Werror
 
+package sel
+  ghc-options: -Werror
+
 package *
   ghc-options: -haddock
-  documentation: True
 
 test-show-details: direct
 tests: True
+documentation: True

sel/sel.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               sel
-version:            0.0.2.0
+version:            0.0.3.0
 category:           Cryptography
 synopsis:           Cryptography for the casual user
 description:
@@ -62,14 +62,19 @@ library
     Sel.SecretKey.Cipher
     Sel.SecretKey.Stream
 
-  other-modules:   Sel.Internal
+  other-modules:
+    Sel.Internal
+    Sel.Internal.Scoped
+    Sel.Internal.Scoped.Foreign
+
   build-depends:
     , base                >=4.14   && <5
     , base16              ^>=1.0
     , bytestring          >=0.10   && <0.13
     , libsodium-bindings  ^>=0.0.2
     , text                >=1.2    && <2.2
     , text-display        ^>=0.0
+    , transformers        ^>=0.6.0
 
 test-suite sel-tests
   import:         common

sel/src/Sel/Internal/Scoped.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- |
+-- Module      : Sel.Internal.Scoped
+-- Description : Continuation-passing utilities
+-- Copyright   : (c) Jack Henahan, 2024
+-- License     : BSD-3-Clause
+-- Maintainer  : The Haskell Cryptography Group
+-- Portability : GHC only
+--
+-- This module implements a version of @Codensity@, modeling delimited
+-- continuations. Useful for avoiding extreme rightward drift in
+-- chains of @withForeignPtr@ and friends.
+module Sel.Internal.Scoped where
+
+import Control.Monad (ap, void)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Trans.Class (MonadTrans (lift))
+import Data.Kind (Type)
+import Data.Type.Equality (type (~~))
+import GHC.Exts (RuntimeRep, TYPE)
+
+-- | @since 0.0.3.0
+type Scoped :: forall {k} {rep :: RuntimeRep}. (k -> TYPE rep) -> Type -> Type
+newtype Scoped m a = Scoped {runScoped :: forall b. (a -> m b) -> m b}
+
+-- | @since 0.0.3.0
+instance Functor (Scoped f) where
+  fmap f (Scoped m) = Scoped $ \k -> m (k . f)
+  {-# INLINE fmap #-}
+
+-- | @since 0.0.3.0
+instance Applicative (Scoped f) where
+  pure a = Scoped $ \k -> k a
+  {-# INLINE pure #-}
+
+  (<*>) = ap
+  {-# INLINE (<*>) #-}
+
+-- | @since 0.0.3.0
+instance Monad (Scoped f) where
+  Scoped m >>= f = Scoped $ \k ->
+    m $ \a -> runScoped (f a) k
+  {-# INLINE (>>=) #-}
+
+-- | @since 0.0.3.0
+instance (MonadIO m', m' ~~ m) => MonadIO (Scoped m) where
+  liftIO = lift . liftIO
+  {-# INLINE liftIO #-}
+
+-- | @since 0.0.3.0
+instance MonadTrans Scoped where
+  lift m = Scoped (m >>=)
+  {-# INLINE lift #-}
+
+-- | @since 0.0.3.0
+reset :: Monad m => Scoped m a -> Scoped m a
+reset = lift . use
+
+-- | @since 0.0.3.0
+shift :: Applicative m => (forall b. (a -> m b) -> Scoped m b) -> Scoped m a
+shift f = Scoped $ use . f
+
+-- | @since 0.0.3.0
+use :: Applicative m => Scoped m a -> m a
+use (Scoped m) = m pure
+
+-- | @since 0.0.3.0
+useM :: Monad m => Scoped m (m a) -> m a
+useM f = use $ f >>= lift
+
+-- | @since 0.0.3.0
+use_ :: Applicative m => Scoped m a -> m ()
+use_ = void . use
+
+-- | @since 0.0.3.0
+useM_ :: Monad m => Scoped m (m a) -> m ()
+useM_ = void . useM

sel/src/Sel/Internal/Scoped/Foreign.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+
+-- |
+-- Module      : Sel.Internal.Scoped.Foreign
+-- Description : Scoped wrappers around pointer manipulation
+-- Copyright   : (c) Jack Henahan, 2024
+-- License     : BSD-3-Clause
+-- Maintainer  : The Haskell Cryptography Group
+-- Portability : GHC only
+--
+-- This module wraps some common points of contact with 'Ptr',
+-- 'ForeignPtr', and friends up in 'Scoped' for the sake of not saying
+-- 'lift' absolutely everywhere.
+module Sel.Internal.Scoped.Foreign where
+
+import Control.Monad.Trans.Class (lift)
+import Data.ByteString (StrictByteString)
+import Data.ByteString.Unsafe qualified as ByteString
+import Foreign (ForeignPtr, Ptr, Storable)
+import Foreign qualified
+import Foreign.C (CString, CStringLen)
+import Sel.Internal.Scoped
+
+-- | @since 0.0.3.0
+foreignPtr :: ForeignPtr a -> Scoped IO (Ptr a)
+foreignPtr fptr = Scoped $ Foreign.withForeignPtr fptr
+
+-- | @since 0.0.3.0
+unsafeCStringLen :: StrictByteString -> Scoped IO CStringLen
+unsafeCStringLen bs = Scoped $ ByteString.unsafeUseAsCStringLen bs
+
+-- | @since 0.0.3.0
+unsafeCString :: StrictByteString -> Scoped IO CString
+unsafeCString bs = Scoped $ ByteString.unsafeUseAsCString bs
+
+-- | @since 0.0.3.0
+mallocBytes :: Int -> Scoped IO (Ptr a)
+mallocBytes = lift . Foreign.mallocBytes
+
+-- | @since 0.0.3.0
+mallocForeignPtrBytes :: Int -> Scoped IO (ForeignPtr a)
+mallocForeignPtrBytes len = lift $ Foreign.mallocForeignPtrBytes len
+
+-- | @since 0.0.3.0
+copyArray :: Storable a => Ptr a -> Ptr a -> Int -> Scoped IO ()
+copyArray target source len = lift $ Foreign.copyArray target source len