monad-actions 2.0.0.0 → 2.0.1.0

raw patch · 11 files changed

+699/−114 lines, 11 filesdep ~basedep ~template-haskellnew-component:exe:calculatornew-component:exe:calculator-recordsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, template-haskell

API changes (from Hackage documentation)

Files

• README.md +1/−1
• examples/Calculator.hs +157/−0
• examples/CalculatorRecords.hs +194/−0
• monad-actions.cabal +31/−4
• src/Control/Monad/Action.hs +54/−75
• src/Control/Monad/Action/Left.hs +12/−3
• src/Control/Monad/Action/Records.hs +61/−19
• src/Control/Monad/Action/Right.hs +12/−3
• src/Control/Monad/Action/TH.hs +67/−3
• src/Control/Monad/TransformerStack.hs +96/−6
• test/Main.hs +14/−0

@@ -6,5 +6,5 @@ The simpler one uses the `LeftModule`, `RightModule`, and `BiModule` classes defined in `Control.Monad.Action`, and can be used with the `QualifiedDo` extension by qualifying the `do` blocks with either `Control.Monad.Action.Right` or `Control.Monad.Action.Left`. However, it uses incoherent instances.-The second implementation, designed to avoid incoherent and overlapping instances, is defined in `Control.Monad.Action.Records`, and uses the `LeftAction`, `RightAtion`, and `BiAction` types.+The second implementation, designed to avoid incoherent and overlapping instances, is defined in `Control.Monad.Action.Records`, and uses the `LeftAction`, `RightAction`, and `BiAction` types. It is meant to be used with `RecordWildCards` and `RebindableSyntax` and/or `OverloadedRecordDot`.

@@ -0,0 +1,157 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE UndecidableInstances #-}++{- HLINT ignore "Redundant pure" -}++module Main (main) where++import Control.Applicative+import Control.Monad+import Control.Monad.Action+import Control.Monad.Action.Left qualified as L+import Control.Monad.Action.Right qualified as R+import Control.Monad.State hiding (get, put)+import Control.Monad.State qualified as State+import Data.Char+import Data.Complex+import Data.Functor+import Data.List+import System.IO+import Text.Read hiding (get)++newtype Parser a = Parser {getParser :: StateT String Maybe a}+  deriving (Functor, Applicative, Alternative, Monad, MonadState String)++runParser :: Parser a -> String -> Maybe a+runParser = evalStateT . getParser++instance {-# INCOHERENT #-} (Monad m, LeftModule m (StateT String Maybe)) => LeftModule m Parser where+  ljoin = Parser . ljoin . fmap getParser++instance {-# INCOHERENT #-} (Monad m, RightModule m (StateT String Maybe)) => RightModule m Parser where+  rjoin = Parser . rjoin . getParser++instance {-# INCOHERENT #-} (Functor f, LeftModule (StateT String Maybe) f) => LeftModule Parser f where+  ljoin = ljoin . getParser++instance {-# INCOHERENT #-} (Functor f, RightModule (StateT String Maybe) f) => RightModule Parser f where+  rjoin = rjoin . fmap getParser++get :: State s s+get = State.get++put :: s -> State s ()+put = State.put++satisfy :: (Char -> Bool) -> Parser Char+satisfy p = L.do+  s <- get+  (c, s') <- uncons s+  put s'+  if p c then pure c else empty++char :: Char -> Parser Char+char = satisfy . (==)++string :: String -> Parser String+string = traverse char++eof :: Parser ()+eof = L.do+  s <- get+  unless (null s) empty++num :: (Read a, Fractional a) => Parser a+num = R.do+  s <- some (satisfy (`elem` ('.' : ['0' .. '9'])))+  readMaybe s++chainl1 :: (Alternative f, Monad f) => f t -> f (t -> t -> t) -> f t+chainl1 p o = p >>= rest+  where+    rest x =+      ( o >>= \f ->+          p >>= \y -> rest $ f x y+      )+        <|> pure x++chainr1 :: (Alternative f, Monad f) => f t -> f (t -> t -> t) -> f t+chainr1 p o =+  p+    >>= \x ->+      ( fmap ($ x) o+          <*> chainr1 p o+      )+        <|> pure x++addOp :: (Num a) => Parser (a -> a -> a)+addOp = char '+' $> (+) <|> char '-' $> (-)++multOp :: (Fractional a) => Parser (a -> a -> a)+multOp = char '*' $> (*) <|> char '/' $> (/)++powerOp :: (Floating a) => Parser (a -> a -> a)+powerOp = (string "^" <|> string "**") $> (**)++func :: (Floating a) => Parser (a -> a)+func =+  string "exp" $> exp+    <|> string "log" $> log+    <|> string "sqrt" $> sqrt+    <|> string "sin" $> sin+    <|> string "cos" $> cos+    <|> string "tan" $> tan+    <|> string "asin" $> asin+    <|> string "acos" $> acos+    <|> string "atan" $> atan+    <|> string "sinh" $> sinh+    <|> string "cosh" $> cosh+    <|> string "tanh" $> tanh+    <|> string "asinh" $> asinh+    <|> string "acosh" $> acosh+    <|> string "atanh" $> atanh++constant :: (RealFloat a) => Parser (Complex a)+constant = string "pi" $> pi <|> string "e" $> exp 1 <|> char 'i' $> (0 :+ 1)++skipSpaces :: Parser a -> Parser a+skipSpaces p = many (satisfy isSpace) *> p <* many (satisfy isSpace)++complexExpr :: (RealFloat a, Read a) => Parser (Complex a)+complexExpr = chainl1 summand addOp+  where+    summand = chainl1 factor multOp+    factor = do+      sign <- skipSpaces $ fmap (maybe 1 (\case '-' -> -1; _ -> 1)) . optional $ satisfy (`elem` "+-")+      p <- chainl1 implicitFactor $ many (satisfy isSpace) $> (*)+      pure $ sign * p+    implicitFactor = chainr1 operand powerOp+    operand =+      skipSpaces $+        fmap (:+ 0) num+          <|> func <*> factor+          <|> constant+          <|> (char '(' *> complexExpr <* char ')')++toString :: (Num a, Eq a, Show a, Ord a) => Complex a -> String+toString = \case+  (0 :+ 0) -> "0"+  (0 :+ 1) -> "i"+  (0 :+ (-1)) -> "-i"+  (0 :+ y) -> show' y ++ " i"+  (x :+ 0) -> show' x+  (x :+ 1) -> show' x ++ " + i"+  (x :+ (-1)) -> show' x ++ " - i"+  (x :+ y) -> show' x ++ (if y >= 0 then " + " else " - ") ++ show' (abs y) ++ " i"+  where+    show' x = if '.' `elem` show x then reverse . dropWhile (== '.') . dropWhile (== '0') . reverse $ show x else show x++main :: IO ()+main = forever $ do+  putStr "> "+  hFlush stdout+  x <- getLine+  let g = runParser (complexExpr @Double <* eof) x+  maybe (hPutStrLn stderr "?") (putStrLn . toString) g

@@ -0,0 +1,194 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoGeneralisedNewtypeDeriving #-}++module Main (main) where++import Control.Applicative (Alternative (..), Applicative (pure, (*>), (<*)), optional)+import Control.Monad (forever, unless)+import Control.Monad.Action.Records+import Control.Monad.State hiding (get, put)+import Control.Monad.State qualified as State+import Data.Char+import Data.Complex+import Data.Functor+import Data.List+import GHC.Records+import System.IO+import Text.Read hiding (get)+import Prelude+  ( Bool (..),+    Double,+    Eq (..),+    Floating (..),+    Fractional (..),+    Maybe,+    Monad,+    Num (..),+    Ord (..),+    RealFloat,+    Show (..),+    String,+    Traversable (..),+    const,+    id,+    maybe,+    ($),+    (.),+  )+import Prelude qualified as P++type Parser a = StateT String Maybe a++ifThenElse :: Bool -> a -> a -> a+ifThenElse = \case+  True -> const+  False -> const id++runParser :: Parser a -> String -> Maybe a+runParser = evalStateT++get :: Parser String+get = State.get++put :: String -> Parser ()+put = State.put++satisfy :: (Char -> Bool) -> Parser Char+satisfy p =+  let LeftAction {..} = transformerStackAction.left+   in do+        s <- get+        (c, s') <- uncons s+        put s'+        if p c then pure c else empty++char :: Char -> Parser Char+char = satisfy . (==)++string :: String -> Parser String+string = traverse char++eof :: Parser ()+eof =+  let LeftAction {..} = submonadAction.left+   in do+        s <- get+        unless (null s) empty++num :: (Read a, Fractional a) => Parser a+num =+  let RightAction {..} = transformerStackAction.right+   in do+        s <- some (satisfy (`elem` ('.' : ['0' .. '9'])))+        readMaybe s++chainl1 :: (Alternative f, Monad f) => f t -> f (t -> t -> t) -> f t+chainl1 p o = p P.>>= rest+  where+    rest x =+      ( o P.>>= \f ->+          p P.>>= \y -> rest $ f x y+      )+        <|> pure x++chainr1 :: (Alternative f, Monad f) => f t -> f (t -> t -> t) -> f t+chainr1 p o =+  p+    P.>>= \x ->+      ( fmap ($ x) o+          P.<*> chainr1 p o+      )+        <|> pure x++addOp :: (Num a) => Parser (a -> a -> a)+addOp = char '+' $> (+) <|> char '-' $> (-)++multOp :: (Fractional a) => Parser (a -> a -> a)+multOp = char '*' $> (*) <|> char '/' $> (/)++powerOp :: (Floating a) => Parser (a -> a -> a)+powerOp = (string "^" <|> string "**") $> (**)++func :: (Floating a) => Parser (a -> a)+func =+  string "exp"+    $> exp+      <|> string "log"+    $> log+      <|> string "sqrt"+    $> sqrt+      <|> string "sin"+    $> sin+      <|> string "cos"+    $> cos+      <|> string "tan"+    $> tan+      <|> string "asin"+    $> asin+      <|> string "acos"+    $> acos+      <|> string "atan"+    $> atan+      <|> string "sinh"+    $> sinh+      <|> string "cosh"+    $> cosh+      <|> string "tanh"+    $> tanh+      <|> string "asinh"+    $> asinh+      <|> string "acosh"+    $> acosh+      <|> string "atanh"+    $> atanh++constant :: (RealFloat a) => Parser (Complex a)+constant = string "pi" $> pi <|> string "e" $> exp 1 <|> char 'i' $> (0 :+ 1)++skipSpaces :: Parser a -> Parser a+skipSpaces p = many (satisfy isSpace) *> p <* many (satisfy isSpace)++complexExpr :: (RealFloat a, Read a) => Parser (Complex a)+complexExpr = chainl1 summand addOp+  where+    summand = chainl1 factor multOp+    factor = P.do+      sign <- skipSpaces $ fmap (maybe 1 (\case '-' -> -1; _ -> 1)) . optional $ satisfy (`elem` "+-")+      p <- chainl1 implicitFactor $ many (satisfy isSpace) $> (*)+      pure $ sign * p+    implicitFactor = chainr1 operand powerOp+    operand =+      skipSpaces $+        fmap (:+ 0) num+          <|> func+          P.<*> factor+            <|> constant+            <|> (char '(' *> complexExpr <* char ')')++toString :: (Num a, Eq a, Show a, Ord a) => Complex a -> String+toString = \case+  (0 :+ 0) -> "0"+  (0 :+ 1) -> "i"+  (0 :+ (-1)) -> "-i"+  (0 :+ y) -> show' y ++ " i"+  (x :+ 0) -> show' x+  (x :+ 1) -> show' x ++ " + i"+  (x :+ (-1)) -> show' x ++ " - i"+  (x :+ y) -> show' x ++ (if y >= 0 then " + " else " - ") ++ show' (abs y) ++ " i"+  where+    show' x = if '.' `elem` show x then reverse . dropWhile (== '.') . dropWhile (== '0') . reverse $ show x else show x++main :: IO ()+main = forever $ P.do+  putStr "> "+  hFlush stdout+  x <- getLine+  let g = runParser (complexExpr @Double <* eof) x+  maybe (hPutStrLn stderr "?") (putStrLn . toString) g

@@ -8,7 +8,7 @@ --       +-+------- breaking API changes --       | | +----- non-breaking API additions --       | | | +--- code changes with no API change-version: 2.0.0.0+version: 2.0.1.0 synopsis: Actions of monads on functors description:   This package defines classes for left and right actions of@@ -46,19 +46,46 @@    other-modules: Control.Monad.Action.TH   build-depends:-   base >= 4.20.2 && < 4.21,+   base >= 4.20.2 && < 4.23,    free >= 5.2 && < 5.3,    kan-extensions >= 5.2.8 && < 5.3,    mmorph >= 1.2.2 && < 1.3,    mtl >= 2.3.1 && < 2.4,-   template-haskell >= 2.22.0 && < 2.23,+   template-haskell >= 2.22.0 && < 2.25,    transformers >= 0.6.1 && < 0.7,    constraints >= 0.14.4 && < 0.15, +  hs-source-dirs: src+  default-language: GHC2021 +flag examples+  description: Build examples+  default:     False+  manual:      True -  hs-source-dirs: src+executable calculator+  import: warnings+  if !flag(examples)+    buildable: False   default-language: GHC2021+  hs-source-dirs: examples+  main-is: Calculator.hs+  build-depends:+        monad-actions,+        base >= 4.20.2 && < 4.23,+        mtl >= 2.3.1 && < 2.4,++executable calculator-records+  import: warnings+  if !flag(examples)+    buildable: False+  default-language: GHC2021+  hs-source-dirs: examples+  main-is: CalculatorRecords.hs+  build-depends:+        monad-actions,+        base >= 4.20.2 && < 4.23,+        mtl >= 2.3.1 && < 2.4,  test-suite monad-actions-test   import: warnings

@@ -1,28 +1,39 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK show-extensions #-} --- | Given a monad \(M\) on a category \(\mathcal{D}\) with unit \(\eta\) and---     multiplication \(\mu\) and a functor \(F\) from \(\mathcal{C}\) to \(\mathcal{D}\),---     a left (or outer) monad action of \(M\) on \(F\) is a natural transformation---     \(\nu: M \circ F \to F\) such that the following two laws hold:+-- |+-- Module      : Control.Monad.Action+-- Description : monad actions+-- Copyright   : © noiioiu+-- License     : LGPL-2+-- Maintainer  : noiioiu@cocaine.ninja+-- Stability   : experimental -----     * \(\nu \cdot (\eta \circ F) = \mathrm{id}_F\)---     * \(\nu \cdot (\mu \circ F) = \nu \cdot (M \circ \nu)\)+-- Given a monad \(M\) on a category \(\mathcal{D}\) with unit \(\eta\) and+-- multiplication \(\mu\) and a functor \(F\) from \(\mathcal{C}\) to \(\mathcal{D}\),+-- a left (or outer) monad action of \(M\) on \(F\) is a natural transformation+-- \(\nu: M \circ F \to F\) such that the following two laws hold: -----     We also say that \(F\) is a left module over \(M\).  In the case---     \(\mathcal{C} = \mathcal{D}\), a left monad module is a left monoid module---     object in the category of endofunctors on \(\mathcal{C}\).  We may also---     call \(\nu\) the scalar multiplication of the module by the monad, by analogy---     with ring modules, which are monoid module objects in the category of abelian groups---     with tensor product as the monoidal product (rings are just monoid objects in this---     category).+-- * \(\nu \cdot (\eta \circ F) = \mathrm{id}_F\)+-- * \(\nu \cdot (\mu \circ F) = \nu \cdot (M \circ \nu)\) -----     Right (or inner) monad actions are defined similarly.+-- We also say that \(F\) is a left module over \(M\).  In the case+-- \(\mathcal{C} = \mathcal{D}\), a left monad module is a left monoid module+-- object in the category of endofunctors on \(\mathcal{C}\).  We may also+-- call \(\nu\) the scalar multiplication of the module by the monad, by analogy+-- with ring modules, which are monoid module objects in the category of abelian groups+-- with tensor product as the monoidal product (rings are just monoid objects in this+-- category). -----     See [this blog post](https://stringdiagram.com/2023/04/23/monad-actions/) by Dan Marsden---     or the paper /Modules over monads and their algebras/ by Piróg, Wu, and Gibbons.+-- Right (or inner) monad actions are defined similarly.+--+-- See [this blog post](https://stringdiagram.com/2023/04/23/monad-actions/) by Dan Marsden+-- or the paper /Modules over monads and their algebras/ by Piróg, Wu, and Gibbons. module Control.Monad.Action   ( LeftModule (..),     RightModule (..),@@ -31,23 +42,30 @@ where  import Control.Monad (join)+import Control.Monad.Accum (MonadAccum (..))+import Control.Monad.Action.TH (mkMTLActions, (#)) import Control.Monad.Codensity (Codensity (..)) import Control.Monad.Error.Class (MonadError (..), liftEither)-import Control.Monad.IO.Class+import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Identity (Identity (..))+import Control.Monad.RWS.Class (MonadRWS) import Control.Monad.Reader.Class (MonadReader (..))-import Control.Monad.State (State, runState)+import Control.Monad.State () import Control.Monad.State.Class (MonadState (..))+import Control.Monad.State.Strict ()+import Control.Monad.Trans.Accum (Accum, runAccum) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT (..))-import Control.Monad.Trans.Reader (Reader, runReader)-import Control.Monad.Trans.Writer (Writer, runWriter)-import Control.Monad.TransformerStack+import Control.Monad.Trans.Reader ()+import Control.Monad.Trans.Writer ()+import Control.Monad.TransformerStack (IsRWS (..), IsReader (..), IsState (..), IsWriter (..), MonadTransStack (..), rws)+import Control.Monad.Writer.CPS () import Control.Monad.Writer.Class (MonadWriter (..))+import Control.Monad.Writer.Strict () import Data.Functor.Compose (Compose (..)) import Data.List.NonEmpty qualified as NE (NonEmpty, toList) import Data.Maybe (catMaybes, mapMaybe)-import Data.Tuple (swap)+import Language.Haskell.TH (Exp (..), Type (..))  -- | Instances must satisfy the following laws: --@@ -211,65 +229,26 @@ instance {-# INCOHERENT #-} (MonadError e m) => BiModule (Either e) (Either e) m  -- | For every @'MonadReader'@ instance defined in "Control.Monad.Reader.Class", @'reader'@ is a monad homomorphism.-instance {-# INCOHERENT #-} (MonadReader r m) => LeftModule ((->) r) m where-  ljoin = join . reader-  a `lbind` f = reader a >>= f--instance {-# INCOHERENT #-} (MonadReader r m) => RightModule ((->) r) m where-  rjoin = (>>= reader)-  a `rbind` f = a >>= reader . f--instance {-# INCOHERENT #-} (MonadReader r m) => BiModule ((->) r) ((->) r) m--instance {-# INCOHERENT #-} (MonadReader r m) => LeftModule (Reader r) m where-  ljoin = join . reader . runReader-  a `lbind` f = reader (runReader a) >>= f--instance {-# INCOHERENT #-} (MonadReader r m) => RightModule (Reader r) m where-  rjoin = (>>= reader . runReader)-  a `rbind` f = a >>= reader . runReader . f--instance {-# INCOHERENT #-} (MonadReader r m) => BiModule (Reader r) (Reader r) m--instance {-# INCOHERENT #-} (MonadReader r m) => BiModule ((->) r) (Reader r) m--instance {-# INCOHERENT #-} (MonadReader r m) => BiModule (Reader r) ((->) r) m---- | For every @'MonadWriter'@ instance defined in "Control.Monad.Writer.Class", @'writer'@ is a monad homomorphism.-instance {-# INCOHERENT #-} (MonadWriter w m) => LeftModule ((,) w) m where-  ljoin = join . writer . swap-  a `lbind` f = writer (swap a) >>= f--instance {-# INCOHERENT #-} (MonadWriter w m) => RightModule ((,) w) m where-  rjoin = (>>= writer . swap)-  a `rbind` f = a >>= writer . swap . f--instance {-# INCOHERENT #-} (MonadWriter w m) => BiModule ((,) w) ((,) w) m--instance {-# INCOHERENT #-} (MonadWriter w m) => LeftModule (Writer w) m where-  ljoin = join . writer . runWriter-  a `lbind` f = writer (runWriter a) >>= f--instance {-# INCOHERENT #-} (MonadWriter w m) => RightModule (Writer w) m where-  rjoin = (>>= writer . runWriter)-  a `rbind` f = a >>= writer . runWriter . f+$(mkMTLActions ''IsReader (VarE 'runReader) (VarE 'reader) (\case AppT _ r -> ConT ''MonadReader # r; _ -> TupleT 0)) -instance {-# INCOHERENT #-} (MonadWriter w m) => BiModule (Writer w) (Writer w) m+-- | For every @'MonadWriter'@ instance defined in "Control.Monad.Writer.Class", @'writer' '.' 'runWriter'@ is a monad homomorphism.+$(mkMTLActions ''IsWriter (VarE 'runWriter) (VarE 'writer) (\case AppT _ w -> ConT ''MonadWriter # w; _ -> TupleT 0)) -instance {-# INCOHERENT #-} (MonadWriter w m) => BiModule ((,) w) (Writer w) m+-- | For every @'MonadState'@ instance defined in "Control.Monad.State.Class", @'state' '.' 'runState'@ is a monad homomorphism.+$(mkMTLActions ''IsState (VarE 'runState) (VarE 'state) (\case AppT _ s -> ConT ''MonadState # s; _ -> TupleT 0)) -instance {-# INCOHERENT #-} (MonadWriter w m) => BiModule (Writer w) ((,) w) m+$(mkMTLActions ''IsRWS (VarE 'runRWS) (VarE 'rws) (\case AppT (AppT (AppT _ r) w) s -> ConT ''MonadRWS # r # w # s; _ -> TupleT 0)) --- | For every @'MonadState'@ instance defined in "Control.Monad.State.Class", @'state'@ is a monad homomorphism.-instance {-# INCOHERENT #-} (MonadState s m) => LeftModule (State s) m where-  ljoin = join . state . runState-  a `lbind` f = state (runState a) >>= f+-- | For every lawful @'MonadAccum'@ instance, @'accum' '.' 'runAccum'@ is a monad homomorphism.+instance {-# INCOHERENT #-} (MonadAccum w m) => LeftModule (Accum w) m where+  ljoin = join . accum . runAccum+  a `lbind` f = accum (runAccum a) >>= f -instance {-# INCOHERENT #-} (MonadState s m) => RightModule (State s) m where-  rjoin = (>>= (state . runState))-  a `rbind` f = a >>= state . runState . f+instance {-# INCOHERENT #-} (MonadAccum w m) => RightModule (Accum w) m where+  rjoin = (>>= (accum . runAccum))+  a `rbind` f = a >>= accum . runAccum . f -instance {-# INCOHERENT #-} (MonadState s m) => BiModule (State s) (State s) m+instance {-# INCOHERENT #-} (MonadAccum w m) => BiModule (Accum w) (Accum w) m  -- | Proof that @f@ is always a left module over @t'Codensity' f@: --

@@ -1,5 +1,13 @@--- | Operators for left monad actions.---   This module should be imported qualified, and can be used with the @QualifiedDo@ extension.+-- |+-- Module      : Control.Monad.Action.Left+-- Description : operators for left monad actions+-- Copyright   : © noiioiu+-- License     : LGPL-2+-- Maintainer  : noiioiu@cocaine.ninja+-- Stability   : experimental+--+-- Operators for left monad actions.+-- This module should be imported qualified, and can be used with the @QualifiedDo@ extension. module Control.Monad.Action.Left   ( (>>=),     (>>),@@ -18,6 +26,7 @@  import Control.Monad.Action import Control.Monad.Fix qualified as F+import GHC.Stack (HasCallStack) import Prelude hiding (fail, fmap, pure, return, (<*>), (=<<), (>>), (>>=)) import Prelude qualified as P @@ -64,7 +73,7 @@ pure = P.pure  -- | Re-export from "Prelude".-fail :: (MonadFail m) => String -> m a+fail :: (HasCallStack, MonadFail m) => String -> m a fail = P.fail  -- | Re-export from "Control.Monad.Fix".

@@ -4,27 +4,50 @@ {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE NoGeneralisedNewtypeDeriving #-}+{-# OPTIONS_HADDOCK show-extensions #-} --- | This module should be used with @OverloadedRecordDot@ and/or @RebindableSyntax@ (and @RecordWildCards@).+{- HLINT ignore "Use >>=" -}+{- HLINT ignore "Use =<<" -}+{- HLINT ignore "Use <=<" -}+{- HLINT ignore "Use >=>" -}++-- |+-- Module      : Control.Monad.Action.Records+-- Description : monad actions, implemented using records+-- Copyright   : © noiioiu+-- License     : LGPL-2+-- Maintainer  : noiioiu@cocaine.ninja+-- Stability   : experimental+--+-- This module should be used with @OverloadedRecordDot@ and/or @RebindableSyntax@ (and @RecordWildCards@). module Control.Monad.Action.Records where -import Control.Monad qualified as M (Monad (..), join, (=<<))+import Control.Monad qualified as M (join, (=<<))+import Control.Monad.Accum (MonadAccum (..)) import Control.Monad.Codensity (Codensity (..)) import Control.Monad.Error.Class (MonadError, liftEither) import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.RWS (MonadRWS, RWS, RWST (..), runRWS)+import Control.Monad.RWS (MonadRWS, RWS, RWST (..))+import Control.Monad.RWS.CPS qualified as RWSCPS (RWS)+import Control.Monad.RWS.Strict qualified as RWSStrict (RWS) import Control.Monad.Reader (MonadReader (..), Reader, ReaderT (..), runReader)-import Control.Monad.State (MonadState (..), State, StateT (..), runState)+import Control.Monad.State (MonadState (..), State, StateT (..))+import Control.Monad.State.Strict qualified as StateStrict (State)+import Control.Monad.Trans.Accum (Accum, runAccum) import Control.Monad.Trans.Writer (WriterT (..))-import Control.Monad.TransformerStack-import Control.Monad.Writer (MonadWriter (..), Writer, runWriter)+import Control.Monad.TransformerStack (IsRWS (..), IsState (..), IsWriter (..), MonadTransStack (..), rws)+import Control.Monad.Writer (MonadWriter (..), Writer)+import Control.Monad.Writer.CPS qualified as WriterCPS (Writer)+import Control.Monad.Writer.Strict qualified as WriterStrict (Writer) import Data.Bifunctor (second) import Data.Constraint (Dict (..)) import Data.Functor.Compose (Compose (..)) import Data.Kind (Constraint, Type) import Data.List.NonEmpty qualified as NE import Data.Maybe (maybeToList)+import Data.Tuple (swap) import Prelude hiding ((<*>), (=<<), (>>), (>>=)) import Prelude qualified as P @@ -200,25 +223,43 @@ instance (MonadIO m) => IO :<: m where   inject = liftIO -instance (MonadState s m) => (State s) :<: m where+instance (MonadState s m) => State s :<: m where   inject = state . runState -instance (MonadReader r m) => (Reader r) :<: m where+instance (MonadState s m) => StateStrict.State s :<: m where+  inject = state . runState++instance (MonadReader r m) => (->) r :<: m where+  inject = reader++instance (MonadReader r m) => Reader r :<: m where   inject = reader . runReader -instance (MonadWriter w m) => (Writer w) :<: m where+instance (MonadWriter w m) => (,) w :<: m where+  inject = writer . swap++instance (MonadWriter w m) => Writer w :<: m where   inject = writer . runWriter -instance (MonadRWS r w s m) => (RWS r w s) :<: m where-  inject t =-    ask P.>>= \r ->-      get P.>>= \s ->-        let (a, s', w) = runRWS t r s-         in put s'-              M.>> tell w-              M.>> pure a+instance (MonadWriter w m) => WriterCPS.Writer w :<: m where+  inject = writer . runWriter -instance (MonadError e m) => (Either e) :<: m where+instance (MonadWriter w m) => WriterStrict.Writer w :<: m where+  inject = writer . runWriter++instance (MonadAccum w m) => Accum w :<: m where+  inject = accum . runAccum++instance (MonadRWS r w s m) => RWS r w s :<: m where+  inject = rws . runRWS++instance (MonadRWS r w s m) => RWSCPS.RWS r w s :<: m where+  inject = rws . runRWS++instance (MonadRWS r w s m) => RWSStrict.RWS r w s :<: m where+  inject = rws . runRWS++instance (MonadError e m) => Either e :<: m where   inject = liftEither  class CodensityAction m f where@@ -226,6 +267,7 @@   codensityBind :: forall a b. m a -> (a -> f b) -> f b   codensityApply :: forall a b. m (a -> b) -> f a -> f b +-- | Left action of the codensity monad of any functor @f@ on @f@. codensityAction :: LeftAction CodensityAction codensityAction =   let join :: forall m f a. (CodensityAction m f) => m (f a) -> f a

@@ -1,7 +1,15 @@ {-# LANGUAGE MonoLocalBinds #-} --- | Operators for right monad actions.---   This module should be imported qualified, and can be used with the @QualifiedDo@ extension.+-- |+-- Module      : Control.Monad.Action.Right+-- Description : operators for right monad actions+-- Copyright   : © noiioiu+-- License     : LGPL-2+-- Maintainer  : noiioiu@cocaine.ninja+-- Stability   : experimental+--+-- Operators for right monad actions.+-- This module should be imported qualified, and can be used with the @QualifiedDo@ extension. module Control.Monad.Action.Right   ( (>>=),     (>>),@@ -20,6 +28,7 @@  import Control.Monad.Action import Control.Monad.Fix qualified as F+import GHC.Stack (HasCallStack) import Prelude hiding (fail, fmap, pure, return, (<*>), (=<<), (>>), (>>=)) import Prelude qualified as P @@ -66,7 +75,7 @@ pure = P.pure  -- | Re-export from "Prelude".-fail :: (MonadFail m) => String -> m a+fail :: (HasCallStack, MonadFail m) => String -> m a fail = P.fail  -- | Re-export from "Control.Monad.Fix".

@@ -2,8 +2,9 @@ {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeData #-} -module Control.Monad.Action.TH (mkLiftBy) where+module Control.Monad.Action.TH (mkLiftBy, mkMTLActions, (#)) where +import Control.Monad (join) import Control.Monad.Trans import Data.Kind qualified as K import Language.Haskell.TH@@ -16,6 +17,69 @@ (|->|) :: Type -> Type -> Type a |->| b = ArrowT # a # b +mkMTLActions :: Name -> Exp -> Exp -> (Type -> Type) -> Q [Dec]+mkMTLActions className run inj classToMTLClass =+  reify className+    >>= \case+      ClassI _ instances -> do+        f <- newName "f"+        a <- newName "a"+        g <- newName "g"+        let leftmoduleDecs =+              instances >>= \case+                InstanceD _ ct (AppT cls m) _ ->+                  pure $+                    InstanceD+                      (Just Incoherent)+                      ((classToMTLClass cls # VarT f) : ct)+                      (ConT (mkName "LeftModule") # m # VarT f)+                      [ ValD+                          (VarP $ mkName "ljoin")+                          (NormalB . UInfixE (VarE 'join) (VarE '(.)) $ UInfixE inj (VarE '(.)) run)+                          [],+                        FunD+                          (mkName "lbind")+                          [ Clause+                              [VarP a, VarP g]+                              (NormalB $ UInfixE (AppE inj (AppE run (VarE a))) (VarE '(>>=)) (VarE g))+                              []+                          ]+                      ]+                _ -> []+        let rightmoduleDecs =+              instances >>= \case+                InstanceD _ ct (AppT cls m) _ ->+                  pure $+                    InstanceD+                      (Just Incoherent)+                      ((classToMTLClass cls # VarT f) : ct)+                      (ConT (mkName "RightModule") # m # VarT f)+                      [ ValD+                          (VarP $ mkName "rjoin")+                          (NormalB . InfixE Nothing (VarE '(>>=)) . Just . UInfixE inj (VarE '(.)) $ run)+                          [],+                        FunD+                          (mkName "rbind")+                          [ Clause+                              [VarP a, VarP g]+                              (NormalB $ UInfixE (VarE a) (VarE '(>>=)) $ UInfixE inj (VarE '(.)) $ UInfixE run (VarE '(.)) (VarE g))+                              []+                          ]+                      ]+                _ -> []+        let bimoduleDecs =+              do+                InstanceD _ ct (AppT cls m) _ <- instances+                InstanceD _ ct' (AppT cls' n) _ <- instances+                pure $+                  InstanceD+                    (Just Incoherent)+                    ((classToMTLClass cls # VarT f) : (classToMTLClass cls' # VarT f) : ct ++ ct')+                    (ConT (mkName "BiModule") # m # n # VarT f)+                    []+        pure $ leftmoduleDecs ++ rightmoduleDecs ++ bimoduleDecs+      _ -> pure []+ mkLiftBy :: Q [Dec] mkLiftBy =   reify ''MonadTrans@@ -40,8 +104,8 @@                 ClosedTypeFamilyD                   ( TypeFamilyHead                       famName-                      [ KindedTV m BndrReq (StarT |->| StarT),-                        KindedTV n BndrReq (StarT |->| StarT)+                      [ KindedTV m BndrReq (ConT ''K.Type |->| ConT ''K.Type),+                        KindedTV n BndrReq (ConT ''K.Type |->| ConT ''K.Type)                       ]                       (KindSig . ConT $ mkName "Nat")                       Nothing

@@ -1,14 +1,41 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeData #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoGeneralisedNewtypeDeriving #-}+{-# OPTIONS_HADDOCK show-extensions #-} -module Control.Monad.TransformerStack (MonadTransStack (..)) where+-- |+-- Module      : Control.Monad.TransformerStack+-- Description : stacks of monad transformers+-- Copyright   : © noiioiu+-- License     : LGPL-2+-- Maintainer  : noiioiu@cocaine.ninja+-- Stability   : experimental+module Control.Monad.TransformerStack+  ( MonadTransStack (..),+    IsState (..),+    IsWriter (..),+    IsRWS (..),+    IsReader (..),+    rws,+  )+where +import Control.Monad.Accum () import Control.Monad.Action.TH import Control.Monad.Co ()+import Control.Monad.RWS.CPS qualified as CPSRWS (RWS, runRWS)+import Control.Monad.RWS.Class (MonadRWS, MonadReader (..), MonadWriter (..))+import Control.Monad.RWS.Lazy qualified as LazyRWS (RWS, runRWS)+import Control.Monad.RWS.Strict qualified as StrictRWS (RWS, runRWS)+import Control.Monad.Reader qualified as Reader+import Control.Monad.State.Class (MonadState (..))+import Control.Monad.State.Lazy qualified as LazyState (State, runState)+import Control.Monad.State.Strict qualified as StrictState (State, runState) import Control.Monad.Trans () import Control.Monad.Trans.Accum () import Control.Monad.Trans.Compose ()@@ -28,6 +55,11 @@ import Control.Monad.Trans.Writer.CPS () import Control.Monad.Trans.Writer.Lazy () import Control.Monad.Trans.Writer.Strict ()+import Control.Monad.Writer.CPS qualified as CPSWriter (Writer, runWriter)+import Control.Monad.Writer.Class ()+import Control.Monad.Writer.Lazy qualified as LazyWriter (Writer, runWriter)+import Control.Monad.Writer.Strict qualified as StrictWriter (Writer, runWriter)+import Data.Tuple (swap)  $mkLiftBy @@ -75,7 +107,7 @@ --   >         ├───  =          ├───  =  ────── --   > ────────┘        ────────┘ -----   In other words,+--   Or in Haskell notation: -- --   @   'Control.Monad.Action.ljoin' '.' 'pure' --   = 'Control.Monad.join' '.' 'liftStack' '.' 'pure'@@ -90,7 +122,7 @@ --   > ────────┘         ────────┘              ├───┘ --   >                                     ─────┘ -----   In other words,+--   Or in Haskell notation: -- --   @  'Control.Monad.Action.ljoin' '.' 'Control.Monad.join' --   = 'Control.Monad.join' '.' 'liftStack' '.' 'Control.Monad.join'@@ -114,7 +146,7 @@ --   >         ├───  =          ├───  =  ────── --   >   ├┈┈►──┘          ├─────┘ -----   In other words,+--   Or in Haskell notation: -- --   @   'Control.Monad.Action.rjoin' '.' 'fmap' 'pure' --   = 'Control.Monad.join' '.' 'fmap' 'liftStack' , 'pure'@@ -131,7 +163,7 @@ --   >    ├┈┈►─┘              ├───┘         ┈┈┈┈┈┈┈►─┘ --   > ┈┈┈┘              ┈┈►──┘ -----   In other words,+--   Or in Haskell notation: -- --   @  'Control.Monad.Action.rjoin' '.' 'fmap' 'Control.Monad.join' --   = 'Control.Monad.join' '.' 'fmap' 'liftStack' '.' 'fmap' 'Control.Monad.join'@@ -150,7 +182,7 @@ --   > ┈►───────┘         ┈┈┈┈┈┈►─┘              ├───┘ --   >                                       ┈┈►─┘ -----   In other words,+--   Or in Haskell notation: -- --   @  'Control.Monad.Action.bijoin' --   = 'Control.Monad.join' '.' 'Control.Monad.join' '.' 'liftStack' '.' 'fmap' ('fmap' 'liftStack')@@ -167,3 +199,61 @@  instance (LiftBy (Steps m n) m n) => MonadTransStack m n where   liftStack = liftBy @(Steps m n)++-- | @'IsReader' r m@ means that @m@ is an implementation of the reader monad, or, in other words, @'reader'@ is a monad isomorphism whose inverse is @'runReader'@.+class (MonadReader r m) => IsReader r m where+  runReader :: forall a. m a -> r -> a++instance IsReader r ((->) r) where+  runReader = id++instance IsReader r (Reader.Reader r) where+  runReader = Reader.runReader++-- | @'IsState' s m@ means that @m@ is an implementation of the state monad, or, in other words, @'state'@ is a monad isomorphism whose inverse is @'runState'@.+class (MonadState s m) => IsState s m where+  runState :: forall a. m a -> s -> (a, s)++instance IsState s (LazyState.State s) where+  runState = LazyState.runState++instance IsState s (StrictState.State s) where+  runState = StrictState.runState++-- | @'IsWriter' w m@ means that @m@ is an implementation of the writer monad, or, in other words, @'writer'@ is a monad isomorphism whose inverse is @'runWriter'@.+class (MonadWriter w m) => IsWriter w m where+  runWriter :: forall a. m a -> (a, w)++instance (Monoid w) => IsWriter w ((,) w) where+  runWriter = swap++instance (Monoid w) => IsWriter w (LazyWriter.Writer w) where+  runWriter = LazyWriter.runWriter++instance (Monoid w) => IsWriter w (StrictWriter.Writer w) where+  runWriter = StrictWriter.runWriter++instance (Monoid w) => IsWriter w (CPSWriter.Writer w) where+  runWriter = CPSWriter.runWriter++-- | @'IsRWS' r w s m@ means that @m@ is an implementation of the rws monad, or, in other words, @'rws'@ is a monad isomorphism whose inverse is @'runRWS'@.+class (MonadRWS r w s m) => IsRWS r w s m where+  runRWS :: forall a. m a -> r -> s -> (a, s, w)++instance (Monoid w) => IsRWS r w s (LazyRWS.RWS r w s) where+  runRWS = LazyRWS.runRWS++instance (Monoid w) => IsRWS r w s (StrictRWS.RWS r w s) where+  runRWS = StrictRWS.runRWS++instance (Monoid w) => IsRWS r w s (CPSRWS.RWS r w s) where+  runRWS = CPSRWS.runRWS++rws :: (MonadRWS r w s m) => (r -> s -> (a, s, w)) -> m a+rws f =+  ask >>= \r ->+    get >>= \s ->+      let (a, s', w) = f r s+       in put s'+            >> tell w+            >> pure a

@@ -21,8 +21,10 @@ import Control.Monad.Trans.Compose import Control.Monad.Trans.Free (FreeF (..), FreeT (..)) import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Writer.CPS qualified as CPSWriter import Control.Monad.TransformerStack import Control.Monad.Writer+import Control.Monad.Writer.Strict qualified as StrictWriter import Data.Functor.Classes (Eq1) import Data.Functor.Compose import Data.Monoid@@ -240,9 +242,18 @@ instance (Arbitrary (m (a, w))) => Arbitrary (WriterT w m a) where   arbitrary = WriterT <$> arbitrary +instance (Arbitrary (m (a, w))) => Arbitrary (StrictWriter.WriterT w m a) where+  arbitrary = StrictWriter.WriterT <$> arbitrary++instance (Arbitrary (m (a, w)), Monoid w, Monad m, Arbitrary a, Arbitrary w) => Arbitrary (CPSWriter.WriterT w m a) where+  arbitrary = writer <$> arbitrary+ instance (EqProp (m (a, w))) => EqProp (WriterT w m a) where   a =-= b = runWriterT a =-= runWriterT b +instance (Show (m (a, w)), Monoid w) => Show (CPSWriter.WriterT w m a) where+  show a = show $ CPSWriter.runWriterT a+ ldotest :: StateT Char [] Int ldotest = L.do   x <- [1, 2, 3, 4, 5]@@ -316,6 +327,9 @@                   leftmodule @((,) (Sum Int)) @(MaybeT (WriterT (Sum Int) Maybe)) @Int,                   rightmodule @((,) (Sum Int)) @(MaybeT (WriterT (Sum Int) Maybe)) @Int,                   bimodule @((,) (Sum Int)) @((,) (Sum Int)) @(MaybeT (WriterT (Sum Int) Maybe)) @Int,+                  bimodule @(Writer (Sum Int)) @(Writer (Sum Int)) @(MaybeT (WriterT (Sum Int) Maybe)) @Int,+                  bimodule @(Writer (Sum Int)) @(StrictWriter.Writer (Sum Int)) @(MaybeT (WriterT (Sum Int) Maybe)) @Int,+                  bimodule @(CPSWriter.Writer (Sum Int)) @(Writer (Sum Int)) @(MaybeT (WriterT (Sum Int) Maybe)) @Int,                   rightmodulestate @(WriterT (Product Int) (Either Double)) @Int @Char                   -- , rightmodulereader @(WriterT (Product Int) (Either Double)) @Int @Char                   -- , rightmodulereader @(Either Bool) @Char @Int