diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ _A data structure for emission plans_ [![License](https://img.shields.io/badge/license-MIT-green)](./LICENSE) -![Hackage Version](https://img.shields.io/hackage/v/effable) +[![Hackage Version](https://img.shields.io/hackage/v/effable)](https://hackage.haskell.org/package/effable) ![CI](https://img.shields.io/github/actions/workflow/status/carlwr/effable/ci.yml?label=CI)
diff --git a/effable.cabal b/effable.cabal --- a/effable.cabal +++ b/effable.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: effable -version: 0.3.1.0 +version: 0.3.1.1 stability: experimental category: Data synopsis: A data structure for emission plans diff --git a/src/Data/Effable.hs b/src/Data/Effable.hs --- a/src/Data/Effable.hs +++ b/src/Data/Effable.hs @@ -108,8 +108,8 @@ import Data.Word (Word8) import Data.Foldable import Data.Maybe qualified as Maybe -import Data.List qualified as L import System.Environment qualified as Env +import Control.Exception qualified as E {- implementation notes: @@ -122,6 +122,8 @@ - instances of "\ \" etc. in docstrings are used to sync vertical alignment/whitespace padding between code and the generated haddock +- "> >>> ..." in docstrings can be used to inhibit doctest execution of the line yet have haddock render it as ">>> ..." + - haddock table bug: won't render if following immediately after heading - workaround: put a ` ` (= SGML whitespace) between @@ -130,7 +132,12 @@ {- $setup >>> import Data.Word (Word8) >>> import Control.Monad +>>> import Data.Foldable >>> :set -XOverloadedStrings + +Overrides for env_example: +>>> isShellM = pure True :: IO Bool +>>> isVerboseM = pure False :: IO Bool -} @@ -766,135 +773,217 @@ --- example --- ------- +-- note: for reasons of making tests deterministic, for some bindings, doctests will use hard-coded values from the $setup block + {- $env_example ->>> import qualified System.Environment as Env ->>> import qualified Data.List as L ->>> import qualified Data.Maybe as Maybe +The following creates an t'Effable' that -Preparation - create some helper functions: +- represents a sequence of 'String's, and +- conditionally includes each 'String' based on an 'IO' action evaluated at emission time. ->>> haveVar name = Maybe.isJust <$> Env.lookupEnv name ->>> envVarsM = L.genericLength <$> Env.getEnvironment :: IO Word8 ->>> envVars = embedAction envVarsM :: Effable IO Word8 +>>> import qualified System.Environment as Env +>>> import qualified Data.Maybe as Maybe -Create an 'Effable', using @OverloadedStrings@ to promote 'String' literals like @"shell-invoked"@ to an 'Effable': +> >>> isShellM = Maybe.isJust <$> Env.lookupEnv "SHELL" :: IO Bool +> >>> isVerboseM = Maybe.isJust <$> Env.lookupEnv "EFF_VERBOSE" :: IO Bool >>> :set -XOverloadedStrings >>> :{ -eff = - (show <$> envVars) `onlyIf` haveVar "DBG" - <> "shell-invoked" `onlyIf` haveVar "SHELL" - <> "DONE." +linesEff :: Effable IO String +linesEff = + "shell-invoked" `onlyIf` isShellM + <> "verbose-info" `onlyIf` isVerboseM + <> "DONE." :} -Depending on the environment variables present, running the 'Effable' with 'putStrLn' would return an @'IO' ()@ that prints something matching this: +To emit the value, we use 'run' with 'putStrLn' as the emission function. The results shown below assume @SHELL@ is a set environment variable but + @EFF_VERBOSE@ is not. ->>> run putStrLn eff -... +>>> :{ +printEff :: Effable IO String -> IO () +printEff = run putStrLn +:} + +>>> printEff linesEff +shell-invoked DONE. -E.g. if 92 environment variables are set, two of which are @DBG@ and @SHELL@, the following would be printed: +The embedded 'String's can be 'fmap'-ed, e.g.: -> >>> run putStrLn eff -> 92 -> shell-invoked -> DONE. +>>> :{ +leftline :: String -> String +leftline = ("| " <>) +:} -__It is crucial that the code was written so that the IO action yielded a 'Word8'.__ It has 256 inhabitants, which is manageable. +>>> printEff (leftline <$> linesEff) +| shell-invoked +| DONE. -== Comparison: IO-monadic code +It should be noted that the functionality we implemented above could just as well have been expressed without t'Effable': a value of type @'IO' ['String']@ can be equally capable. Its lines could be 'fmap'-ed with @leftline@, and including each list element (= line) could be conditioned on an @'IO' 'Bool'@. -This version, written directly in the IO monad, is equivalent in what it prints: +=== Adding a wrapper + +Let's say we have this function: + +>>> import qualified Control.Exception as E +>>> >>> :{ -monadicIO = do - isDbg <- haveVar "DBG" - isShell <- haveVar "SHELL" - -- - n <- envVarsM - let nStr = show n - -- - when isDbg $ putStrLn nStr - when isShell $ putStrLn "shell-invoked" - putStrLn "DONE." +-- | Run an IO action and then print a line indicating +-- whether it threw an exception or not. +withReporting :: IO () -> IO () +withReporting x = do + r <- E.try x + case (r :: Either E.SomeException ()) of + Left _ -> putStrLn "(FAIL)" + Right _ -> putStrLn "(OK)" :} ->>> monadicIO -... +The following t'Effable' will apply @withReporting@ to any emission of the first 'String': + +>>> :{ +linesEff_reporting :: Effable IO String +linesEff_reporting = + wrap withReporting ("shell-invoked" `onlyIf` isShellM ) + <> ("verbose-info" `onlyIf` isVerboseM) + <> "DONE." +:} + +E.g.: + +>>> printEff linesEff_reporting +shell-invoked +(OK) DONE. -== @eff@ vs. @monadicIO@ +>>> printEff (leftline <$> linesEff_reporting) +| shell-invoked +(OK) +| DONE. -- (-) blows-up unless @envVarsM@ is carefully implemented to limit the domain of what the action returns +The second output includes the line -- (-) is slower, and more expensive in allocations +> (OK) -- (+) is pure, and has a type that allows further transformations: +rather than - > --- GHCi session --- - > - > λ> :t eff - > eff :: Effable IO String - > - > λ> :t monadicIO - > monadicIO :: IO () +> | (OK) - ...e.g.: +which is the intended behaviour: - > >>> leftline = ("| "<>) - > >>> run putStrLn (leftline <$> eff) - > | 92 - > | shell-invoked - > | DONE. +- @leftline '<$>' ..@ modifies each embedded 'String' (= line), while +- @'wrap' withReporting@ modifies how each line is emitted. +The above example illustrates that an t'Effable' with an emission wrapper still retains transformability, e.g. with 'fmap'. If we would not use an t'Effable' but instead create an @'IO' _@ that includes the wrapper, it would have to be an @'IO' ()@ - which is opaque and no longer transformable. + -} -_env_example_docstring :: IO () -_env_example_docstring = main_env_example - where +{- | Code used in the example. (internal/for maintenance + typechecking) - haveVar :: String -> IO Bool - haveVar name = Maybe.isJust <$> Env.lookupEnv name - envVarsM = L.genericLength <$> Env.getEnvironment :: IO Word8 - envVars = embedAction envVarsM :: Effable IO Word8 +Useful terminal command: +```sh +(unset EFF_VERBOSE; SHELL=true cabal repl --repl-options="-e _env_example_code") +``` +-} +_env_example_code :: IO () +_env_example_code = printExpressions where - eff = - (show <$> envVars) `onlyIf` haveVar "DBG" - <> "shell-invoked" `onlyIf` haveVar "SHELL" - <> "DONE." + -- Effable without wrapper + -- ----------------------- - _res0 = run putStrLn eff + isShellM = Maybe.isJust <$> Env.lookupEnv "SHELL" :: IO Bool + isVerboseM = Maybe.isJust <$> Env.lookupEnv "EFF_VERBOSE" :: IO Bool - monadicIO :: IO () - monadicIO = do - isDbg <- haveVar "DBG" - isShell <- haveVar "SHELL" + linesEff :: Effable IO String + linesEff = + "shell-invoked" `onlyIf` isShellM + <> "verbose-info" `onlyIf` isVerboseM + <> "DONE." - n <- envVarsM - let nStr = show n + printEff :: Effable IO String -> IO () + printEff = run putStrLn - when isDbg $ putStrLn nStr - when isShell $ putStrLn "shell-invoked" - putStrLn "DONE." + leftline :: String -> String + leftline = ("| " <>) - leftline = ("| "<>) - _res_leftline = run putStrLn (leftline <$> eff) + _res_effWithout = printEff linesEff + _res_effWithout_ll = printEff (leftline <$> linesEff) - main_env_example :: IO () - main_env_example = do - print . length . inEffable $ eff - print . length . inEffable $ ifThenElse (haveVar "SHELL") eff eff - putStrLn "\n_res0:" ; _res0 - putStrLn "\n_res_leftline"; _res_leftline - putStrLn "\nmonadic:" ; monadicIO + -- Effable WITH wrapper + -- -------------------- - -- not used: `eff` expressed with a do-block: - _eff_do :: Effable IO String - _eff_do = do - n <- envVars - let nStr = show n - l1 <- when' (haveVar "DBG" ) (string nStr) - l2 <- when' (haveVar "SHELL") "shell-invoked" - pure (l1 <> l2 <> "DONE.") + withReporting :: IO () -> IO () + withReporting x = do + r <- E.try x + case (r :: Either E.SomeException ()) of + Left _ -> putStrLn "(FAIL)" + Right _ -> putStrLn "(OK)" + + linesEff_reporting :: Effable IO String + linesEff_reporting = + wrap withReporting ("shell-invoked" `onlyIf` isShellM ) + <> ("verbose-info" `onlyIf` isVerboseM) + <> "DONE." + + _res_eff_reporting = printEff linesEff_reporting + _res_eff_reporting_ll = printEff (leftline <$> linesEff_reporting) + + + -- Implementations in IO (no Effable) + -- ---------------------------------- + + -- (keep this code even if not used in the docstring) + + linesIO :: IO [String] + linesIO = do + isShell <- isShellM + isVerbose <- isVerboseM + pure $ + (if isShell then ["shell-invoked"] else []) + ++ (if isVerbose then ["verbose-info" ] else []) + ++ ["DONE."] + + printIO :: IO [String] -> IO () + printIO_ll :: IO [String] -> IO () + printIO_ll' :: IO [String] -> IO () + + printIO x = x >>= traverse_ putStrLn + printIO_ll x = x >>= traverse_ (putStrLn . leftline) -- "modify emission" + printIO_ll' x = printIO $ fmap leftline <$> x -- "modify value" + + printIO__linesIO__reporting :: IO () + printIO__linesIO__reporting = do + isShell <- isShellM + isVerbose <- isVerboseM + withReporting $ when isShell $ putStrLn "shell-invoked" + id $ when isVerbose $ putStrLn "verbose-info" + putStrLn "DONE." + + + -- (For observing what the expressions print) + -- ------------------------------------------ + + printExpressions :: IO () + printExpressions = do + put "\n=== Effable without wrapper ===" + put "--- plain:" ; printEff linesEff + put "--- leftlined:" ; printEff (leftline <$> linesEff) + + put "\n=== Effable WITH wrapper ===" + put "--- plain:" ; printEff linesEff_reporting + put "--- leftlined:" ; printEff (leftline <$> linesEff_reporting) + + put "\n-----------------------------------" + + put "\n=== IO [String] without wrapper ===" + put "--- plain:" ; printIO linesIO + put "--- leftlined em.:" ; printIO_ll linesIO + put "--- leftlined value:"; printIO_ll' linesIO + + put "\n=== IO [String] WITH wrapper ===" + put "--- (plain, opaque):"; printIO__linesIO__reporting + + where + put s = putStrLn ("\n" ++ s)