diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index b3edf57..292ffd8 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -14,7 +14,7 @@ jobs: strategy: matrix: os: [ubuntu-latest, macos-latest, windows-latest] - ghc: ['8.10', '9.2', '9.8', '9.10', '9.12', 9.14] + ghc: ['8.10', '9.2', '9.8', '9.10', '9.12', '9.14'] exclude: - os: macos-latest ghc: '8.10' # ghc-8.10 does not support ARM @@ -46,6 +46,9 @@ jobs: - name: Build run: cabal build + - name: Test + run: cabal test + mhs: runs-on: ubuntu-latest steps: @@ -53,7 +56,7 @@ jobs: uses: actions/checkout@v4 with: repository: augustss/MicroHs - ref: v0.15.4.0 + ref: v0.16.0.0 path: mhs - name: make and install mhs diff --git a/Control/Monad/Trans/Compose.hs b/Control/Monad/Trans/Compose.hs new file mode 100644 index 0000000..ec9a06c --- /dev/null +++ b/Control/Monad/Trans/Compose.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE Trustworthy #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Compose +-- Copyright : (C) 2026 The transformers Authors +-- License : BSD-style (see the file LICENSE) +-- +-- This combines two transformers into a single compound transformer. +-- Potentially useful for when a single transformer is required as a type +-- argument. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Compose ( + ComposeT (..), +) where + +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus) +import Control.Monad.Fix (MonadFix) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Zip (MonadZip) +import Data.Data (Data) +import Data.Functor.Classes (Eq1, Ord1) +import Data.Functor.Compose (Compose) +import Data.Functor.Contravariant (Contravariant) +import Data.Kind (Type) +#ifdef __GLASGOW_HASKELL__ +import GHC.Generics (Generic) +#endif + +infixr 9 `ComposeT` + +-- | Like its analogue `Compose`, @ComposeT@ is polykinded; typically it will +-- have kind +-- +-- > ((Type -> Type) -> Type -> Type) -> ((Type -> Type) -> Type -> Type) -> (Type -> Type) -> Type -> Type +-- +-- After enabling @{-# LANGUAGE TypeOperators #-}@, the `ComposeT` type +-- constructor may be written in infix notation in signatures and is +-- right-associative, mirroring `(.)`. Example: +-- +-- > type FallibleCountT = ExceptT String `ComposeT` StateT Int +-- > +-- > checkNonNeg :: (Monad m) => FallibleCountT m () +-- > checkNonNeg = ComposeT $ do +-- > count <- lift get +-- > when (count < 0) $ throwE $ "count is negative (" ++ show count ++ ")" +-- +type ComposeT :: forall k1 k2 k3. + (k3 -> k2 -> Type) -> (k1 -> k3) -> (k1 -> k2 -> Type) +newtype ComposeT t1 t2 m a = ComposeT { runComposeT :: t1 (t2 m) a } + deriving stock ( + Functor, + Traversable, + Foldable, + Eq, + Ord, + Read, + Show, +#ifdef __GLASGOW_HASKELL__ + Generic, +#endif + Data) + deriving newtype ( + Contravariant, + Applicative, + Monad, + MonadIO, + Alternative, + MonadFail, + MonadPlus, + MonadFix, + MonadZip, + Semigroup, + Monoid, + Eq1, + Ord1, + Bounded, + Enum, + Fractional, + Floating, + Real, + RealFrac, + RealFloat, + Integral, + Num) + +instance (MonadTrans t1, MonadTrans t2) => MonadTrans (ComposeT t1 t2) where + lift = ComposeT . lift . lift + {-# INLINE lift #-} diff --git a/test/ComposeT.hs b/test/ComposeT.hs new file mode 100644 index 0000000..6b73862 --- /dev/null +++ b/test/ComposeT.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TypeOperators #-} + +module Main (main) where + +import Data.Functor.Identity +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.State.Lazy +import Control.Monad.Trans.Compose +import System.Exit + +type FallibleCountT = ExceptT String `ComposeT` StateT Int + +checkNonNeg :: (Monad m) => FallibleCountT m () +checkNonNeg = ComposeT $ do + count <- lift get + when (count < 0) $ throwE $ "count is negative (" ++ show count ++ ")" + +main :: IO () +main = do + let negateAndCheck = lift (modify negate) >> runComposeT checkNonNeg + unitOrE = runIdentity $ evalStateT (runExceptT negateAndCheck) (-10) + + either die return unitOrE diff --git a/transformers.cabal b/transformers.cabal index 90b3131..5894e4f 100644 --- a/transformers.cabal +++ b/transformers.cabal @@ -46,7 +46,7 @@ tested-with: ghc ==9.14 ghc ==9.2 ghc ==9.8 - mhs ==0.15 + mhs ==0.16 source-repository head type: git @@ -63,6 +63,7 @@ library Control.Monad.Signatures Control.Monad.Trans.Accum Control.Monad.Trans.Class + Control.Monad.Trans.Compose Control.Monad.Trans.Cont Control.Monad.Trans.Except Control.Monad.Trans.Identity @@ -82,3 +83,10 @@ library Control.Monad.Trans.Writer.Strict Data.Functor.Constant Data.Functor.Reverse + +test-suite ComposeT + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: ComposeT.hs + default-language: Haskell2010 + build-depends: base, transformers