diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,14 @@ +# ChangeLog / ReleaseNotes + + +## Version 0.1.0.0 + +* First public release. +* Uploaded to [Hackage][]: + + + + +[Hackage]: + http://hackage.haskell.org/ + "HackageDB (or just Hackage) is a collection of releases of Haskell packages." diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013-2015, Peter Trško + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Peter Trško nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,257 @@ +# Endo + +[![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] +[![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] + + +## Description + +Endomorphism utilities. + + +## Usage Examples + +Lets define simple application `Config` data type as: + +````Haskell +data Verbosity = Silent | Normal | Verbose | Annoying + deriving (Show) + +data Config = Config + { _verbosity :: Verbosity + , _outputFile :: FilePath + } + deriving (Show) +```` + +Now lets define setters for `_verbosity` and `_outputFile`: + +````Haskell +setVerbosity :: Verbosity -> E Config +setVerbosity b cfg = cfg{_verbosity = b} + +setOutputFile :: FilePath -> E Config +setOutputFile b cfg = cfg{_outputFile = b} +```` + +Note that E is defined in `Data.Monoid.Endo` module and it looks like: + +````Haskell +type E a = a -> a +```` + +Its purpose is to simplify type signatures. + +Now lets get to our first example: + +````Haskell +example1 :: E Config +example1 = appEndo $ foldEndo + &$ setVerbosity Annoying + &$ setOutputFile "an.out.put" +```` + +Above example shows us that it is possible to modify `Config` as if it was a +monoid, but without actually having to state it as such. In practice it is +not always possible to define it as `Monoid` or at least a `Semigroup`. What +usually works are endomorphisms, like in this example. + +Now, `FilePath` has one pathological case, and that is `""`. There is a lot of +ways to handle it. Here we will concentrate only few basic techniques to +illustrate versatility of our approach. + +````Haskell +-- | Trying to set output file to \"\" will result in keeping original value. +setOutputFile2 :: FilePath -> E Config +setOutputFile2 "" = id +setOutputFile2 fp = setOutputFile fp + +example2 :: E Config +example2 = appEndo $ foldEndo + &$ setVerbosity Annoying + &$ setOutputFile2 "an.out.put" +```` + +Same as above, but exploits `instance AnEndo a => AnEndo Maybe a`: + +````Haskell +setOutputFile3 :: FilePath -> Maybe (E Config) +setOutputFile3 "" = Nothing +setOutputFile3 fp = Just $ setOutputFile fp + +example3 :: E Config +example3 = appEndo $ foldEndo + &$ setVerbosity Annoying + &$ setOutputFile3 "an.out.put" +```` + +Following example uses common pattern of using `Either` as error reporting +monad. This approach can be easily modified for arbitrary error reporting +monad. + +````Haskell +setOutputFile4 :: FilePath -> Either String (E Config) +setOutputFile4 "" = Left "Output file: Empty file path." +setOutputFile4 fp = Right $ setOutputFile fp + +example4 :: Either String (E Config) +example4 = appEndo <&$> foldEndo + <*> pure (setVerbosity Annoying) + <*> setOutputFile4 "an.out.put" +```` + +Notice, that above example uses applicative style. Normally when using this +style, for setting record values, one needs to keep in sync order of +constructor arguments and order of operations. Using `foldEndo` (and its +dual `dualFoldEndo`) doesn't have this restriction. + +Instead of setter functions one may want to use lenses (in terms of +[lens package][Hackage: lens]): + +````Haskell +verbosity :: Lens' Config Verbosity +verbosity = _verbosity ~@@^> \s b -> s{_verbosity = b} + +outputFile :: Lens' Config FilePath +outputFile = _outputFile ~@@^> \s b -> s{_outputFile = b} +```` + +Now setting values of `Config` would look like: + +````Haskell +example5 :: E Config +example5 = appEndo $ foldEndo + &$ verbosity .~ Annoying + &$ outputFile .~ "an.out.put" +```` + +Probably one of the most interesting things that can be done with this +module is following: + +````Haskell +instance AnEndo Verbosity where + type EndoOperatesOn Verbosity = Config + anEndo = Endo . set verbosity + +newtype OutputFile = OutputFile FilePath + +instance AnEndo OutputFile where + type EndoOperatesOn OutputFile = Config + anEndo (OutputFile fp) = Endo $ outputFile .~ fp + +example6 :: E Config +example6 = appEndo $ foldEndo + &$ Annoying + &$ OutputFile "an.out.put" +```` + + +### Using with optparse-applicative + +This is a more complex example that defines parser for +[optparse-applicative][Hackage: optparse-applicative] built on top of some of +the above definitions: + +````Haskell +options :: Parser Config +options = runIdentityT $ runEndo defaultConfig <$> options' + where + options' :: IdentityT Parser (Endo Config) + options' = foldEndo + <*> outputOption -- :: IdentityT Parser (Maybe (E Config)) + <*> verbosityOption -- :: IdentityT Parser (Maybe (E Config)) + <*> annoyingFlag -- :: IdentityT Parser (E Config) + <*> silentFlag -- :: IdentityT Parser (E Config) + <*> verboseFlag -- :: IdentityT Parser (E Config) + + defaultConfig :: Config + defaultConfig = Config Normal "" + +-- >>> :main -o an.out.put --annoying +-- Config {_verbosity = Annoying, _outputFile = "an.out.put"} +main :: IO () +main = execParser (info options fullDesc) >>= print +```` + +Parsers for individual options and flags are wrapped in 'IdentityT', because +there is no `instance FoldEndoArgs r => FoldEndoArgs (Parser r)`, but there is +`instance FoldEndoArgs r => FoldEndoArgs (IdentityT r)`. + +Functions used by the above code: + +````Haskell +outputOption :: IdentityT Parser (Maybe (E Config)) +outputOption = + IdentityT . optional . option (set outputFile <$> parseFilePath) + $ short 'o' <> long "output" <> metavar "FILE" + <> help "Store output in to a FILE." + where + parseFilePath = eitherReader $ \s -> + if null s + then Left "Option argument can not be empty file path." + else Right s + +verbosityOption :: IdentityT Parser (Maybe (E Config)) +verbosityOption = + IdentityT . optional . option (set verbosity <$> parseVerbosity) + $ long "verbosity" <> metavar "LEVEL" <> help "Set verbosity to LEVEL." + where + verbosityToStr = map toLower . Data.showConstr . Data.toConstr + verbosityIntValues = [(show $ fromEnum v, v) | v <- [Silent .. Annoying]] + verbosityStrValues = + ("default", Normal) : [(verbosityToStr v, v) | v <- [Silent .. Annoying]] + + parseVerbosityError = unwords + [ "Verbosity can be only number from interval" + , show $ map fromEnum [minBound, maxBound :: Verbosity] + , "or one of the following:" + , concat . intersperse ", " $ map fst verbosityStrValues + ] + + parseVerbosity = eitherReader $ \s -> + case lookup s $ verbosityIntValues ++ verbosityStrValues of + Just v -> Right v + Nothing -> Left parseVerbosityError + +annoyingFlag :: IdentityT Parser (E Config) +annoyingFlag = IdentityT . flag id (verbosity .~ Annoying) + $ long "annoying" <> help "Set verbosity to maximum." + +silentFlag :: IdentityT Parser (E Config) +silentFlag = IdentityT . flag id (verbosity .~ Silent) + $ short 's' <> long "silent" <> help "Set verbosity to minimum." + +verboseFlag :: IdentityT Parser (E Config) +verboseFlag = IdentityT . flag id (verbosity .~ Verbose) + $ short 'v' <> long "verbose" <> help "Be verbose." +```` + + +Building Options +---------------- + +* `-fpedantic` (disabled by default) + + Pass additional warning flags to GHC. + + +Contributions +------------- + +Contributions, pull requests and bug reports are welcome! Please don't be +afraid to contact author using GitHub or by e-mail. + + + +[Hackage: lens]: + http://hackage.haskell.org/package/lens + "lens package on Hackage" +[Hackage: optparse-applicative]: + http://hackage.haskell.org/package/optparse-applicative + "optparse-applicative package on Hackage" +[Haskell.org]: + http://www.haskell.org + "The Haskell Programming Language" +[tl;dr Legal: BSD3]: + https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 + "BSD 3-Clause License (Revised)" diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/endo.cabal b/endo.cabal new file mode 100644 --- /dev/null +++ b/endo.cabal @@ -0,0 +1,116 @@ +name: endo +version: 0.1.0.0 +synopsis: Endomorphism utilities. +description: + Package defines extra functions for 'Data.Monoid.Endo' data type, and also + generic endomorphism folding machinery. Generic endomorphism folding can be + used for various purposes, including as a builder. + . + Here is an example how to use with + + package: + . + > data Verbosity = Silent | Normal | Verbose | Annoying + > deriving (Show) + . + > data Config = Config Verbosity FilePath + > deriving (Show) + . + > options :: Parser Config + > options = runIdentityT $ runEndo defaultConfig <$> options' + > where + > options' :: IdentityT Parser (Endo Config) + > options' = foldEndo + > <*> outputOption -- IdentityT Parser (Maybe (E Config)) + > <*> verbosityOption -- IdentityT Parser (Maybe (E Config)) + > <*> annoyingFlag -- IdentityT Parser (E Config) + > <*> silentFlag -- IdentityT Parser (E Config) + > <*> verboseFlag -- IdentityT Parser (E Config) + > + > defaultConfig :: Config + > defaultConfig = Config Normal "" + . + > main :: IO () + > main = execParser (info options fullDesc) >>= print + . + > ghci> :main -o an.out.put --annoying + > Config Annoying "an.out.put" + . + For details how individual option parsers look like see module + "Data.Monoid.Endo.Fold" which contains other examples as well as this one. + +homepage: https://github.com/trskop/endo +bug-reports: https://github.com/trskop/endo/issues +license: BSD3 +license-file: LICENSE +author: Peter Trško +maintainer: peter.trsko@gmail.com +copyright: (c) 2013-2015 Peter Trško +category: Data +build-type: Simple +cabal-version: >=1.10 + +-- Examples require lens and optparse-applicative packages in addition to this +-- packackage's dependencies. When using sandbox it is possible to use "cabal +-- repl" to test examples by using following command: +-- +-- cabal repl \ +-- --ghc-option="-iexample" \ +-- --ghc-options="-package lens" \ +-- --ghc-options="-package optparse-applicative" \ +-- --ghc-options="-package transformers" +extra-source-files: + ChangeLog.md + , README.md + , example/Example/Config/*.hs + , example/Example/*.hs + , example/*.hs + +flag pedantic + description: Pass additional warning flags to GHC. + default: False + manual: True + +library + hs-source-dirs: src + exposed-modules: + Data.Monoid.Endo + , Data.Monoid.Endo.Fold + + default-language: Haskell2010 + other-extensions: + DeriveDataTypeable + , DeriveGeneric + , FlexibleInstances + , NoImplicitPrelude + , TypeFamilies + + build-depends: + -- {{{ Distributed with GHC or Haskell Platform --------------------------- + base >=4.6 && <4.8 + , transformers >=0.3 && <0.5 + -- }}} Distributed with GHC or Haskell Platform --------------------------- + + , between == 0.9.* + + if impl(GHC >= 7.8) + cpp-options: -DHAVE_MINIMAL_PRAGMA + -DKIND_POLYMORPHIC_TYPEABLE + if impl(GHC >= 7.9) + cpp-options: -DAPPLICATIVE_MONAD + + ghc-options: -Wall + if flag(pedantic) + ghc-options: + -fwarn-tabs + -fwarn-implicit-prelude +-- -Werror + +source-repository head + type: git + location: git://github.com/trskop/endo.git + +source-repository this + type: git + location: git://github.com/trskop/endo.git + tag: 0.1.0.0 diff --git a/example/Example/Config.hs b/example/Example/Config.hs new file mode 100644 --- /dev/null +++ b/example/Example/Config.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: $HEADER$ +-- Description: Simple example of Config data type. +-- Copyright: (c) 2015 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: experimental +-- Portability: NoImplicitPrelude +-- +-- Simple example of 'Config' data type. Definitions from this package are used +-- in other examples. +module Example.Config (Config(..), Verbosity(..)) + where + +import Prelude (Bounded, Enum) + +import Data.Data (Data) +import Data.Eq (Eq) +import Data.Ord (Ord) +import Text.Show (Show) +import Data.Typeable (Typeable) +import System.IO (FilePath) + + +data Verbosity = Silent | Normal | Verbose | Annoying + deriving (Bounded, Data, Enum, Eq, Ord, Show, Typeable) + +data Config = Config + { _verbosity :: Verbosity + , _outputFile :: FilePath + } + deriving (Show) diff --git a/example/Example/Config/Lens.hs b/example/Example/Config/Lens.hs new file mode 100644 --- /dev/null +++ b/example/Example/Config/Lens.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: $HEADER$ +-- Description: Simple setters for Config data type. +-- Copyright: (c) 2013-2015 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: experimental +-- Portability: NoImplicitPrelude +-- +-- Simple setters for 'Config' data type. Definitions from this package are +-- used in other examples. +module Example.Config.Lens + ( outputFile + , verbosity + ) + where + +import System.IO (FilePath) + +import Control.Lens (Lens') +import Data.Function.Between ((~@@^>)) + +import Example.Config (Config(..), Verbosity) + + +verbosity :: Lens' Config Verbosity +verbosity = _verbosity ~@@^> \s b -> s{_verbosity = b} + +outputFile :: Lens' Config FilePath +outputFile = _outputFile ~@@^> \s b -> s{_outputFile = b} diff --git a/example/Example/Config/Setters.hs b/example/Example/Config/Setters.hs new file mode 100644 --- /dev/null +++ b/example/Example/Config/Setters.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: $HEADER$ +-- Description: Simple setters for Config data type. +-- Copyright: (c) 2013-2015 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: experimental +-- Portability: NoImplicitPrelude +-- +-- Simple setters for 'Config' data type. Definitions from this package are +-- used in other examples. +module Example.Config.Setters + ( setOutputFile + , setVerbosity + ) + where + +import System.IO (FilePath) + +import Data.Monoid.Endo (E) + +import Example.Config (Config(..), Verbosity) + + +setVerbosity :: Verbosity -> E Config +setVerbosity b cfg = cfg{_verbosity = b} + +setOutputFile :: FilePath -> E Config +setOutputFile b cfg = cfg{_outputFile = b} diff --git a/example/Example1.hs b/example/Example1.hs new file mode 100644 --- /dev/null +++ b/example/Example1.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: $HEADER$ +-- Description: Example 1 +-- Copyright: (c) 2015 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: experimental +-- Portability: NoImplicitPrelude +-- +-- Example 1. +module Example1 + where + +import Data.Function (($)) +import Data.Monoid (Endo(appEndo)) + +import Data.Monoid.Endo (E) +import Data.Monoid.Endo.Fold ((&$), foldEndo) + +import Example.Config (Config, Verbosity(Annoying)) +import Example.Config.Setters (setOutputFile, setVerbosity) + + +example1 :: E Config +example1 = appEndo $ foldEndo + &$ setVerbosity Annoying + &$ setOutputFile "an.out.put" diff --git a/example/Example2.hs b/example/Example2.hs new file mode 100644 --- /dev/null +++ b/example/Example2.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: $HEADER$ +-- Description: Example 2 +-- Copyright: (c) 2015 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: experimental +-- Portability: NoImplicitPrelude +-- +-- Example 2. +module Example2 + where + +import Data.Function (($), id) +import Data.Monoid (Endo(appEndo)) + +import Data.Monoid.Endo (E) +import Data.Monoid.Endo.Fold ((&$), foldEndo) + +import Example.Config (Config, Verbosity(Annoying)) +import Example.Config.Setters (setOutputFile, setVerbosity) + + +-- | Trying to set output file to \"\" will result in keeping original value. +setOutputFile2 :: FilePath -> E Config +setOutputFile2 "" = id +setOutputFile2 fp = setOutputFile fp + +example2 :: E Config +example2 = appEndo $ foldEndo + &$ setVerbosity Annoying + &$ setOutputFile2 "an.out.put" diff --git a/example/Example3.hs b/example/Example3.hs new file mode 100644 --- /dev/null +++ b/example/Example3.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: $HEADER$ +-- Description: Example 3 +-- Copyright: (c) 2015 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: experimental +-- Portability: NoImplicitPrelude +-- +-- Example 3. +module Example3 + where + +import Data.Function (($)) +import Data.Maybe (Maybe(Just, Nothing)) +import Data.Monoid (Endo(appEndo)) +import System.IO (FilePath) + +import Data.Monoid.Endo (E) +import Data.Monoid.Endo.Fold ((&$), foldEndo) + +import Example.Config (Config, Verbosity(Annoying)) +import Example.Config.Setters (setOutputFile, setVerbosity) + + +setOutputFile3 :: FilePath -> Maybe (E Config) +setOutputFile3 "" = Nothing +setOutputFile3 fp = Just $ setOutputFile fp + +example3 :: E Config +example3 = appEndo $ foldEndo + &$ setVerbosity Annoying + &$ setOutputFile3 "an.out.put" diff --git a/example/Example4.hs b/example/Example4.hs new file mode 100644 --- /dev/null +++ b/example/Example4.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: $HEADER$ +-- Description: Example 4 +-- Copyright: (c) 2015 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: experimental +-- Portability: NoImplicitPrelude +-- +-- Example 4. +module Example4 + where + +import Control.Applicative (Applicative((<*>), pure)) +import Data.Either (Either(Left, Right)) +import Data.Function (($)) +import Data.Monoid (Endo(appEndo)) +import Data.String (String) +import System.IO (FilePath) + +import Data.Monoid.Endo (E) +import Data.Monoid.Endo.Fold (foldEndo, (<&$>)) + +import Example.Config (Config, Verbosity(Annoying)) +import Example.Config.Setters (setOutputFile, setVerbosity) + + +setOutputFile4 :: FilePath -> Either String (E Config) +setOutputFile4 "" = Left "Output file: Empty file path." +setOutputFile4 fp = Right $ setOutputFile fp + +example4 :: Either String (E Config) +example4 = appEndo <&$> foldEndo + <*> pure (setVerbosity Annoying) + <*> setOutputFile4 "an.out.put" diff --git a/example/Example5.hs b/example/Example5.hs new file mode 100644 --- /dev/null +++ b/example/Example5.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: $HEADER$ +-- Description: Example 5 +-- Copyright: (c) 2015 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: experimental +-- Portability: NoImplicitPrelude +-- +-- Example 5. +module Example5 + where + +import Data.Function (($)) +import Data.Monoid (Endo(appEndo)) + +import Control.Lens ((.~)) +import Data.Monoid.Endo (E) +import Data.Monoid.Endo.Fold ((&$), foldEndo) + +import Example.Config (Config, Verbosity(Annoying)) +import Example.Config.Lens (outputFile, verbosity) + + +example5 :: E Config +example5 = appEndo $ foldEndo + &$ verbosity .~ Annoying + &$ outputFile .~ "an.out.put" diff --git a/example/Example6.hs b/example/Example6.hs new file mode 100644 --- /dev/null +++ b/example/Example6.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module: $HEADER$ +-- Description: Example 6 +-- Copyright: (c) 2015 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: experimental +-- Portability: NoImplicitPrelude, TypeFamilies +-- +-- Example 6. +module Example6 + where + +import Data.Function ((.), ($)) +import Data.Monoid (Endo(Endo, appEndo)) +import System.IO (FilePath) + +import Control.Lens ((.~), set) +import Data.Monoid.Endo (E) +import Data.Monoid.Endo.Fold (AnEndo(anEndo), EndoOperatesOn, (&$), foldEndo) + +import Example.Config (Config, Verbosity(Annoying)) +import Example.Config.Lens (outputFile, verbosity) + + +-- Please ignore warning about orphan instances. +instance AnEndo Verbosity where + type EndoOperatesOn Verbosity = Config + anEndo = Endo . set verbosity + +newtype OutputFile = OutputFile FilePath + +instance AnEndo OutputFile where + type EndoOperatesOn OutputFile = Config + anEndo (OutputFile fp) = Endo $ outputFile .~ fp + +example6 :: E Config +example6 = appEndo $ foldEndo + &$ Annoying + &$ OutputFile "an.out.put" diff --git a/example/Example7.hs b/example/Example7.hs new file mode 100644 --- /dev/null +++ b/example/Example7.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: $HEADER$ +-- Description: Example 7 +-- Copyright: (c) 2015 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: experimental +-- Portability: NoImplicitPrelude +-- +-- Example 2. +module Example7 + where + +import Prelude (Bounded(maxBound, minBound), Enum(fromEnum)) + +import Control.Applicative (Applicative((<*>)), (<$>)) +import Control.Monad (Monad((>>=))) +import Data.Char (toLower) +import qualified Data.Data as Data (Data(toConstr), showConstr) +import Data.Either (Either(Left, Right)) +import Data.Function ((.), ($), id) +import Data.List ((++)) +import Data.List (concat, intersperse, lookup, map, null, unwords) +import Data.Maybe (Maybe(Just, Nothing)) +import Data.Monoid (Endo, (<>)) +import Data.Tuple (fst) +import System.IO (IO, print) +import Text.Show (Show(show)) + +import Control.Monad.Trans.Identity (IdentityT(IdentityT, runIdentityT)) + +import Control.Lens ((.~), set) +import Options.Applicative + ( Parser + , eitherReader + , execParser + , flag + , fullDesc + , help + , info + , long + , metavar + , option + , optional + , short + ) + +import Data.Monoid.Endo (E, runEndo) +import Data.Monoid.Endo.Fold (foldEndo) + +import Example.Config (Config(Config), Verbosity(..)) +import Example.Config.Lens (outputFile, verbosity) + + +options :: Parser Config +options = runIdentityT $ runEndo defaultConfig <$> options' + where + options' :: IdentityT Parser (Endo Config) + options' = foldEndo + <*> outputOption -- :: IdentityT Parser (Maybe (E Config)) + <*> verbosityOption -- :: IdentityT Parser (Maybe (E Config)) + <*> annoyingFlag -- :: IdentityT Parser (E Config) + <*> silentFlag -- :: IdentityT Parser (E Config) + <*> verboseFlag -- :: IdentityT Parser (E Config) + + defaultConfig :: Config + defaultConfig = Config Normal "" + +-- >>> :main -o an.out.put --annoying +-- Config {_verbosity = Annoying, _outputFile = "an.out.put"} +main :: IO () +main = execParser (info options fullDesc) >>= print + +outputOption :: IdentityT Parser (Maybe (E Config)) +outputOption = + IdentityT . optional . option (set outputFile <$> parseFilePath) + $ short 'o' <> long "output" <> metavar "FILE" + <> help "Store output in to a FILE." + where + parseFilePath = eitherReader $ \s -> + if null s + then Left "Option argument can not be empty file path." + else Right s + +verbosityOption :: IdentityT Parser (Maybe (E Config)) +verbosityOption = + IdentityT . optional . option (set verbosity <$> parseVerbosity) + $ long "verbosity" <> metavar "LEVEL" <> help "Set verbosity to LEVEL." + where + verbosityToStr = map toLower . Data.showConstr . Data.toConstr + verbosityIntValues = [(show $ fromEnum v, v) | v <- [Silent .. Annoying]] + verbosityStrValues = + ("default", Normal) : [(verbosityToStr v, v) | v <- [Silent .. Annoying]] + + parseVerbosityError = unwords + [ "Verbosity can be only number from interval" + , show $ map fromEnum [minBound, maxBound :: Verbosity] + , "or one of the following:" + , concat . intersperse ", " $ map fst verbosityStrValues + ] + + parseVerbosity = eitherReader $ \s -> + case lookup s $ verbosityIntValues ++ verbosityStrValues of + Just v -> Right v + Nothing -> Left parseVerbosityError + +annoyingFlag :: IdentityT Parser (E Config) +annoyingFlag = IdentityT . flag id (verbosity .~ Annoying) + $ long "annoying" <> help "Set verbosity to maximum." + +silentFlag :: IdentityT Parser (E Config) +silentFlag = IdentityT . flag id (verbosity .~ Silent) + $ short 's' <> long "silent" <> help "Set verbosity to minimum." + +verboseFlag :: IdentityT Parser (E Config) +verboseFlag = IdentityT . flag id (verbosity .~ Verbose) + $ short 'v' <> long "verbose" <> help "Be verbose." diff --git a/src/Data/Monoid/Endo.hs b/src/Data/Monoid/Endo.hs new file mode 100644 --- /dev/null +++ b/src/Data/Monoid/Endo.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: $HEADER$ +-- Description: Utilities for Endo data type. +-- Copyright: (c) 2013-2015 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: experimental +-- Portability: NoImplicitPrelude +-- +-- Utilities for 'Endo' data type from "Data.Monoid" module. +module Data.Monoid.Endo + ( + -- * Endo + E + , Endo(..) + , runEndo + , mapEndo + , mapEndo2 + , liftEndo + + -- ** Lens + , endo + ) + where + +import Data.Functor (Functor(fmap)) +import Data.Monoid (Endo(..)) + +import Data.Function.Between ((~@~), (<~@~)) + + +-- | Type synonym for endomorphsm; it can be used simplify type signatures. +type E a = a -> a + +-- | Transform function wrapped in 'Endo'. +mapEndo :: (E a -> E b) -> Endo a -> Endo b +mapEndo = Endo ~@~ appEndo +{-# INLINE mapEndo #-} + +-- | Variation of 'mapEndo' for functions with arity two. +mapEndo2 :: (E a -> E b -> E c) -> Endo a -> Endo b -> Endo c +mapEndo2 = mapEndo ~@~ appEndo +{-# INLINE mapEndo2 #-} + +-- | Apply 'fmap' to function wrapped in 'Endo'. It's a short hand for +-- @'mapEndo' 'fmap'@. +liftEndo :: Functor f => Endo a -> Endo (f a) +liftEndo (Endo f) = Endo (fmap f) +{-# INLINE liftEndo #-} + +-- | Flipped version of 'appEndo'. +runEndo :: a -> Endo a -> a +runEndo x (Endo f) = f x +{-# INLINE runEndo #-} + +-- | Lens for 'Endo'. In terms of /lens/ package it would have type: +-- +-- > endo :: Lens (Endo a) (Endo b) (E a) (E b) +-- +-- For details see . +endo :: Functor f => (E a -> f (E b)) -> Endo a -> f (Endo b) +endo = Endo <~@~ appEndo +{-# INLINE endo #-} diff --git a/src/Data/Monoid/Endo/Fold.hs b/src/Data/Monoid/Endo/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Data/Monoid/Endo/Fold.hs @@ -0,0 +1,913 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} + +#ifdef KIND_POLYMORPHIC_TYPEABLE +{-# LANGUAGE DeriveDataTypeable #-} +#endif + +#if MIN_VERSION_transformers(0,4,0) +-- ExceptT was introduced in transformers == 0.4.0.0 and it deprecated ErrorT. +-- That is also the reason why ErrorT instance is not provided. +#define HAVE_EXCEPTT +#endif + +-- | +-- Module: $HEADER$ +-- Description: Generic folding for various endomorphism representations. +-- Copyright: (c) 2014, 2015 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: experimental +-- Portability: CPP, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, +-- NoImplicitPrelude, TypeFamilies +-- +-- Generic folding for various endomorphism representations. +module Data.Monoid.Endo.Fold + ( + -- * Usage Examples + -- $usageExample + + -- ** Using with optparse-applicative + -- $optparseApplicativeExample + + -- * Generic Endomorphism Folding + foldEndo + , dualFoldEndo + + -- ** Type Classes + , FoldEndoArgs(..) + , AnEndo(..) + + -- ** Type Wrappers + , WrappedFoldable(..) + + -- * Utility Functions + , (&$) + , (<&$>) + ) + where + +import Control.Applicative (Applicative(pure)) +import Control.Monad (Monad(return)) +import Data.Either (Either(Right)) +import Data.Foldable (Foldable(foldMap)) +import Data.Function ((.), id) +import Data.Functor (Functor(fmap)) +import Data.Functor.Identity (Identity(Identity)) +import Data.Maybe (Maybe(Just, Nothing)) +import Data.Monoid (Dual(Dual), Endo(Endo), Monoid(mempty, mconcat), (<>)) +import GHC.Generics (Generic) +import System.IO (IO) +import Text.Read (Read) +import Text.Show (Show) + +#ifdef KIND_POLYMORPHIC_TYPEABLE +import Data.Data (Data) +import Data.Typeable (Typeable) +#endif + +#if HAVE_EXCEPTT +import Control.Monad.Trans.Except (ExceptT) +#endif +import Control.Monad.Trans.Identity (IdentityT) +import Control.Monad.Trans.List (ListT) +import Control.Monad.Trans.Maybe (MaybeT) +import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.Trans.RWS (RWST) +import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST) +import Control.Monad.Trans.State (StateT) +import qualified Control.Monad.Trans.State.Strict as Strict (StateT) +import Control.Monad.Trans.Writer (WriterT) +import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT) +import Data.Functor.Compose (Compose) +import Data.Functor.Product (Product) +import Data.Functor.Reverse (Reverse) + + +-- | Fold all variously represented endomorphisms in to one endomorphism. +-- +-- Order in which endomorphisms are folded is preserved: +-- +-- >>> foldEndo (Endo (1:)) [(2:), (3:)] `appEndo` [] +-- [1,2,3] +-- +-- For numbers it would look like: +-- +-- >>> foldEndo (Endo (+1)) [(+2), (*3)] `appEndo` 1 +-- 6 +-- +-- Above can be seen as: +-- +-- >>> (+1) . (+2) . (*3) $ 1 +-- 6 +foldEndo :: FoldEndoArgs args => args +foldEndo = foldEndoArgs mempty + +-- | Same as 'foldEndo', but folds endomorphisms in reverse order. +-- +-- Following are the same examples as for 'foldEndo' function. Please, note the +-- differences in results. +-- +-- Order in which endomorphisms are folded is reversed: +-- +-- >>> dualFoldEndo (Endo (1:)) [(2:), (3:)] `appEndo` [] +-- [2,3,1] +-- +-- For numbers it would look like: +-- +-- >>> dualFoldEndo (Endo (+1)) [(+2), (*3)] `appEndo` 1 +-- 12 +-- +-- Above can be seen as: +-- +-- >>> (*3) . (+2) . (+1) $ 1 +-- 12 +dualFoldEndo :: FoldEndoArgs args => args +dualFoldEndo = dualFoldEndoArgs mempty + +-- {{{ FoldEndoArgs Type Class ------------------------------------------------ + +-- | Class of arguments for 'foldEndo' and its dual 'dualFoldEndo' functions. +-- +-- Note that results are instances of this ('FoldEndoArgs') class and +-- endomorphism representations are instances of 'AnEndo' type class. +class FoldEndoArgs a where + -- | Extracts type of a value that is modified by the result. + type ResultOperatesOn a + + foldEndoArgs :: Endo (ResultOperatesOn a) -> a + dualFoldEndoArgs :: Dual (Endo (ResultOperatesOn a)) -> a +#ifdef HAVE_MINIMAL_PRAGMA + {-# MINIMAL foldEndoArgs, dualFoldEndoArgs #-} +#endif + +instance + ( AnEndo a + , FoldEndoArgs r + , EndoOperatesOn a ~ ResultOperatesOn r + ) => FoldEndoArgs (a -> r) + where + type ResultOperatesOn (a -> r) = ResultOperatesOn r + foldEndoArgs e e' = foldEndoArgs (e <> anEndo e') + dualFoldEndoArgs e e' = dualFoldEndoArgs (e <> aDualEndo e') + +instance FoldEndoArgs (Endo a) where + type ResultOperatesOn (Endo a) = a + foldEndoArgs = id + dualFoldEndoArgs (Dual e) = e + +instance FoldEndoArgs r => FoldEndoArgs (Either e r) where + type ResultOperatesOn (Either e r) = ResultOperatesOn r + foldEndoArgs = Right . foldEndoArgs + dualFoldEndoArgs = Right . dualFoldEndoArgs + +instance FoldEndoArgs r => FoldEndoArgs (Identity r) where + type ResultOperatesOn (Identity r) = ResultOperatesOn r + foldEndoArgs = Identity . foldEndoArgs + dualFoldEndoArgs = Identity . dualFoldEndoArgs + +instance FoldEndoArgs r => FoldEndoArgs (IO r) where + type ResultOperatesOn (IO r) = ResultOperatesOn r + foldEndoArgs = pure . foldEndoArgs + dualFoldEndoArgs = pure . dualFoldEndoArgs + +instance FoldEndoArgs r => FoldEndoArgs (Maybe r) where + type ResultOperatesOn (Maybe r) = ResultOperatesOn r + foldEndoArgs = Just . foldEndoArgs + dualFoldEndoArgs = Just . dualFoldEndoArgs + +-- {{{ Transformers ----------------------------------------------------------- + +-- {{{ Functor Transformers --------------------------------------------------- + +instance + (Applicative f, Applicative g, FoldEndoArgs r) + => FoldEndoArgs (Compose f g r) + where + type ResultOperatesOn (Compose f g r) = ResultOperatesOn r + foldEndoArgs = pure . foldEndoArgs + dualFoldEndoArgs = pure . dualFoldEndoArgs + +instance + (Applicative f, Applicative g, FoldEndoArgs r) + => FoldEndoArgs (Product f g r) + where + type ResultOperatesOn (Product f g r) = ResultOperatesOn r + foldEndoArgs = pure . foldEndoArgs + dualFoldEndoArgs = pure . dualFoldEndoArgs + +-- }}} Functor Transformers --------------------------------------------------- + +-- {{{ Monad Transformers ----------------------------------------------------- + +-- | This instance can be used in cases when there is no 'FoldEndoArgs' +-- instance for a specific 'Applicative' functor. Example: +-- +-- @ +-- 'Control.Monad.Trans.Identity.runIdentityT' $ 'foldEndo' +-- \<*\> 'IdentityT' parseSomething +-- \<*\> 'IdentityT' parseSomethingElse +-- @ +instance (Applicative f, FoldEndoArgs r) => FoldEndoArgs (IdentityT f r) where + type ResultOperatesOn (IdentityT f r) = ResultOperatesOn r + foldEndoArgs = pure . foldEndoArgs + dualFoldEndoArgs = pure . dualFoldEndoArgs + +#if HAVE_EXCEPTT +instance (Applicative f, FoldEndoArgs r) => FoldEndoArgs (ExceptT e f r) where + type ResultOperatesOn (ExceptT e f r) = ResultOperatesOn r + foldEndoArgs = pure . foldEndoArgs + dualFoldEndoArgs = pure . dualFoldEndoArgs +#endif + +instance (Applicative f, FoldEndoArgs r) => FoldEndoArgs (ListT f r) where + type ResultOperatesOn (ListT f r) = ResultOperatesOn r + foldEndoArgs = pure . foldEndoArgs + dualFoldEndoArgs = pure . dualFoldEndoArgs + +instance + ( Monad m +#ifndef APPLICATIVE_MONAD + , Functor m +#endif + , FoldEndoArgs r + ) => FoldEndoArgs (MaybeT m r) where + type ResultOperatesOn (MaybeT m r) = ResultOperatesOn r + foldEndoArgs = return . foldEndoArgs + dualFoldEndoArgs = return . dualFoldEndoArgs + +instance (Applicative f, FoldEndoArgs r) => FoldEndoArgs (ReaderT r' f r) where + type ResultOperatesOn (ReaderT r' f r) = ResultOperatesOn r + foldEndoArgs = pure . foldEndoArgs + dualFoldEndoArgs = pure . dualFoldEndoArgs + +instance + ( Monad m +#ifndef APPLICATIVE_MONAD + , Functor m +#endif + , Monoid w + , FoldEndoArgs r + ) => FoldEndoArgs (RWST r' w s m r) + where + type ResultOperatesOn (RWST r' w s m r) = ResultOperatesOn r + foldEndoArgs = return . foldEndoArgs + dualFoldEndoArgs = return . dualFoldEndoArgs + +instance + ( Monad m +#ifndef APPLICATIVE_MONAD + , Functor m +#endif + , Monoid w + , FoldEndoArgs r + ) => FoldEndoArgs (Strict.RWST r' w s m r) + where + type ResultOperatesOn (Strict.RWST r' w s m r) = ResultOperatesOn r + foldEndoArgs = return . foldEndoArgs + dualFoldEndoArgs = return . dualFoldEndoArgs + +instance (Monad m, FoldEndoArgs r) => FoldEndoArgs (StateT s m r) where + type ResultOperatesOn (StateT s m r) = ResultOperatesOn r + foldEndoArgs = return . foldEndoArgs + dualFoldEndoArgs = return . dualFoldEndoArgs + +instance (Monad m, FoldEndoArgs r) => FoldEndoArgs (Strict.StateT s m r) where + type ResultOperatesOn (Strict.StateT s m r) = ResultOperatesOn r + foldEndoArgs = return . foldEndoArgs + dualFoldEndoArgs = return . dualFoldEndoArgs + +instance + (Applicative f, FoldEndoArgs r, Monoid w) => FoldEndoArgs (WriterT w f r) + where + type ResultOperatesOn (WriterT w f r) = ResultOperatesOn r + foldEndoArgs = pure . foldEndoArgs + dualFoldEndoArgs = pure . dualFoldEndoArgs + +instance + (Applicative f, FoldEndoArgs r, Monoid w) + => FoldEndoArgs (Strict.WriterT w f r) + where + type ResultOperatesOn (Strict.WriterT w f r) = ResultOperatesOn r + foldEndoArgs = pure . foldEndoArgs + dualFoldEndoArgs = pure . dualFoldEndoArgs + +-- }}} Monad Transformers ----------------------------------------------------- + +-- }}} Transformers ----------------------------------------------------------- + +-- {{{ FoldEndoArgs Type Class ------------------------------------------------ + +-- {{{ AnEndo Type Class ------------------------------------------------------ + +-- | Class that represents various endomorphism representation. In other words +-- anything that encodes @a -> a@ can be instance of this class. +class AnEndo a where + -- | Extract type on which endomorphism operates, e.g. for + -- @'Endo' a@ it would be @a@. + type EndoOperatesOn a + + -- | Convert value encoding @a -> a@ in to 'Endo'. + anEndo :: a -> Endo (EndoOperatesOn a) + + -- | Dual to 'anEndo'. Default implementation: + -- + -- @ + -- 'aDualEndo' = 'Dual' . 'anEndo' + -- @ + aDualEndo :: a -> Dual (Endo (EndoOperatesOn a)) + aDualEndo = Dual . anEndo + +#if HAVE_MINIMAL_PRAGMA + {-# MINIMAL anEndo #-} +#endif + +instance AnEndo (Endo a) where + type EndoOperatesOn (Endo a) = a + anEndo = id + +instance AnEndo (a -> a) where + type EndoOperatesOn (a -> a) = a + anEndo = Endo + +instance AnEndo a => AnEndo (Maybe a) where + type EndoOperatesOn (Maybe a) = EndoOperatesOn a + + anEndo Nothing = mempty + anEndo (Just e) = anEndo e + +-- {{{ Foldable Instances ----------------------------------------------------- + +-- | Wrapper for 'Foldable' instances. +-- +-- This allows using 'foldEndo' and 'dualFoldEndo' for any 'Foldable' instance +-- without the need for @OverlappingInstances@ language extension. +newtype WrappedFoldable f a = WrapFoldable {getFoldable :: f a} + deriving + ( Generic + , Read + , Show +#ifdef KIND_POLYMORPHIC_TYPEABLE + , Data + , Typeable +#endif + ) + +instance (Foldable f, AnEndo a) => AnEndo (WrappedFoldable f a) where + type EndoOperatesOn (WrappedFoldable f a) = EndoOperatesOn a + anEndo (WrapFoldable fa) = foldMap anEndo fa + aDualEndo (WrapFoldable fa) = foldMap aDualEndo fa + +instance AnEndo a => AnEndo [a] where + type EndoOperatesOn [a] = EndoOperatesOn a + anEndo = anEndo . WrapFoldable + aDualEndo = aDualEndo . WrapFoldable + +-- {{{ Transformers ----------------------------------------------------------- + +-- | Fold in reverese order. +instance (Foldable f, AnEndo a) => AnEndo (Reverse f a) where + type EndoOperatesOn (Reverse f a) = EndoOperatesOn a + anEndo = anEndo . WrapFoldable + aDualEndo = aDualEndo . WrapFoldable + +-- }}} Transformers ----------------------------------------------------------- + +-- }}} Foldable Instances ----------------------------------------------------- + +-- {{{ Instances For Tuples --------------------------------------------------- + +instance + ( AnEndo a + , AnEndo b + , EndoOperatesOn a ~ EndoOperatesOn b + ) => AnEndo (a, b) + where + type EndoOperatesOn (a, b) = EndoOperatesOn a + anEndo (a, b) = anEndo a <> anEndo b + aDualEndo (a, b) = aDualEndo a <> aDualEndo b + +instance + ( AnEndo a + , AnEndo b + , AnEndo c + , EndoOperatesOn a ~ EndoOperatesOn b + , EndoOperatesOn a ~ EndoOperatesOn c + ) => AnEndo (a, b, c) + where + type EndoOperatesOn (a, b, c) = EndoOperatesOn a + anEndo (a, b, c) = anEndo a <> anEndo b <> anEndo c + aDualEndo (a, b, c) = aDualEndo a <> aDualEndo b <> aDualEndo c + +instance + ( AnEndo a1 + , AnEndo a2 + , AnEndo a3 + , AnEndo a4 + , EndoOperatesOn a1 ~ EndoOperatesOn a2 + , EndoOperatesOn a1 ~ EndoOperatesOn a3 + , EndoOperatesOn a1 ~ EndoOperatesOn a4 + ) => AnEndo (a1, a2, a3, a4) + where + type EndoOperatesOn (a1, a2, a3, a4) = EndoOperatesOn a1 + anEndo (a1, a2, a3, a4) = mconcat + [ anEndo a1 + , anEndo a2 + , anEndo a3 + , anEndo a4 + ] + + aDualEndo (a1, a2, a3, a4) = mconcat + [ aDualEndo a1 + , aDualEndo a2 + , aDualEndo a3 + , aDualEndo a4 + ] + +instance + ( AnEndo a1 + , AnEndo a2 + , AnEndo a3 + , AnEndo a4 + , AnEndo a5 + , EndoOperatesOn a1 ~ EndoOperatesOn a2 + , EndoOperatesOn a1 ~ EndoOperatesOn a3 + , EndoOperatesOn a1 ~ EndoOperatesOn a4 + , EndoOperatesOn a1 ~ EndoOperatesOn a5 + ) => AnEndo (a1, a2, a3, a4, a5) + where + type EndoOperatesOn (a1, a2, a3, a4, a5) = EndoOperatesOn a1 + + anEndo (a1, a2, a3, a4, a5) = mconcat + [ anEndo a1 + , anEndo a2 + , anEndo a3 + , anEndo a4 + , anEndo a5 + ] + + aDualEndo (a1, a2, a3, a4, a5) = mconcat + [ aDualEndo a1 + , aDualEndo a2 + , aDualEndo a3 + , aDualEndo a4 + , aDualEndo a5 + ] + +instance + ( AnEndo a1 + , AnEndo a2 + , AnEndo a3 + , AnEndo a4 + , AnEndo a5 + , AnEndo a6 + , EndoOperatesOn a1 ~ EndoOperatesOn a2 + , EndoOperatesOn a1 ~ EndoOperatesOn a3 + , EndoOperatesOn a1 ~ EndoOperatesOn a4 + , EndoOperatesOn a1 ~ EndoOperatesOn a5 + , EndoOperatesOn a1 ~ EndoOperatesOn a6 + ) => AnEndo (a1, a2, a3, a4, a5, a6) + where + type EndoOperatesOn (a1, a2, a3, a4, a5, a6) = EndoOperatesOn a1 + + anEndo (a1, a2, a3, a4, a5, a6) = mconcat + [ anEndo a1 + , anEndo a2 + , anEndo a3 + , anEndo a4 + , anEndo a5 + , anEndo a6 + ] + + aDualEndo (a1, a2, a3, a4, a5, a6) = mconcat + [ aDualEndo a1 + , aDualEndo a2 + , aDualEndo a3 + , aDualEndo a4 + , aDualEndo a5 + , aDualEndo a6 + ] + +instance + ( AnEndo a1 + , AnEndo a2 + , AnEndo a3 + , AnEndo a4 + , AnEndo a5 + , AnEndo a6 + , AnEndo a7 + , EndoOperatesOn a1 ~ EndoOperatesOn a2 + , EndoOperatesOn a1 ~ EndoOperatesOn a3 + , EndoOperatesOn a1 ~ EndoOperatesOn a4 + , EndoOperatesOn a1 ~ EndoOperatesOn a5 + , EndoOperatesOn a1 ~ EndoOperatesOn a6 + , EndoOperatesOn a1 ~ EndoOperatesOn a7 + ) => AnEndo (a1, a2, a3, a4, a5, a6, a7) + where + type EndoOperatesOn (a1, a2, a3, a4, a5, a6, a7) = EndoOperatesOn a1 + + anEndo (a1, a2, a3, a4, a5, a6, a7) = mconcat + [ anEndo a1 + , anEndo a2 + , anEndo a3 + , anEndo a4 + , anEndo a5 + , anEndo a6 + , anEndo a7 + ] + + aDualEndo (a1, a2, a3, a4, a5, a6, a7) = mconcat + [ aDualEndo a1 + , aDualEndo a2 + , aDualEndo a3 + , aDualEndo a4 + , aDualEndo a5 + , aDualEndo a6 + , aDualEndo a7 + ] + +instance + ( AnEndo a1 + , AnEndo a2 + , AnEndo a3 + , AnEndo a4 + , AnEndo a5 + , AnEndo a6 + , AnEndo a7 + , AnEndo a8 + , EndoOperatesOn a1 ~ EndoOperatesOn a2 + , EndoOperatesOn a1 ~ EndoOperatesOn a3 + , EndoOperatesOn a1 ~ EndoOperatesOn a4 + , EndoOperatesOn a1 ~ EndoOperatesOn a5 + , EndoOperatesOn a1 ~ EndoOperatesOn a6 + , EndoOperatesOn a1 ~ EndoOperatesOn a7 + , EndoOperatesOn a1 ~ EndoOperatesOn a8 + ) => AnEndo (a1, a2, a3, a4, a5, a6, a7, a8) + where + type EndoOperatesOn (a1, a2, a3, a4, a5, a6, a7, a8) = EndoOperatesOn a1 + + anEndo (a1, a2, a3, a4, a5, a6, a7, a8) = mconcat + [ anEndo a1 + , anEndo a2 + , anEndo a3 + , anEndo a4 + , anEndo a5 + , anEndo a6 + , anEndo a7 + , anEndo a8 + ] + + aDualEndo (a1, a2, a3, a4, a5, a6, a7, a8) = mconcat + [ aDualEndo a1 + , aDualEndo a2 + , aDualEndo a3 + , aDualEndo a4 + , aDualEndo a5 + , aDualEndo a6 + , aDualEndo a7 + , aDualEndo a8 + ] + +instance + ( AnEndo a1 + , AnEndo a2 + , AnEndo a3 + , AnEndo a4 + , AnEndo a5 + , AnEndo a6 + , AnEndo a7 + , AnEndo a8 + , AnEndo a9 + , EndoOperatesOn a1 ~ EndoOperatesOn a2 + , EndoOperatesOn a1 ~ EndoOperatesOn a3 + , EndoOperatesOn a1 ~ EndoOperatesOn a4 + , EndoOperatesOn a1 ~ EndoOperatesOn a5 + , EndoOperatesOn a1 ~ EndoOperatesOn a6 + , EndoOperatesOn a1 ~ EndoOperatesOn a7 + , EndoOperatesOn a1 ~ EndoOperatesOn a8 + , EndoOperatesOn a1 ~ EndoOperatesOn a9 + ) => AnEndo (a1, a2, a3, a4, a5, a6, a7, a8, a9) + where + type EndoOperatesOn (a1, a2, a3, a4, a5, a6, a7, a8, a9) = EndoOperatesOn a1 + + anEndo (a1, a2, a3, a4, a5, a6, a7, a8, a9) = mconcat + [ anEndo a1 + , anEndo a2 + , anEndo a3 + , anEndo a4 + , anEndo a5 + , anEndo a6 + , anEndo a7 + , anEndo a8 + , anEndo a9 + ] + + aDualEndo (a1, a2, a3, a4, a5, a6, a7, a8, a9) = mconcat + [ aDualEndo a1 + , aDualEndo a2 + , aDualEndo a3 + , aDualEndo a4 + , aDualEndo a5 + , aDualEndo a6 + , aDualEndo a7 + , aDualEndo a8 + , aDualEndo a9 + ] + +instance + ( AnEndo a1 + , AnEndo a2 + , AnEndo a3 + , AnEndo a4 + , AnEndo a5 + , AnEndo a6 + , AnEndo a7 + , AnEndo a8 + , AnEndo a9 + , AnEndo a10 + , EndoOperatesOn a1 ~ EndoOperatesOn a2 + , EndoOperatesOn a1 ~ EndoOperatesOn a3 + , EndoOperatesOn a1 ~ EndoOperatesOn a4 + , EndoOperatesOn a1 ~ EndoOperatesOn a5 + , EndoOperatesOn a1 ~ EndoOperatesOn a6 + , EndoOperatesOn a1 ~ EndoOperatesOn a7 + , EndoOperatesOn a1 ~ EndoOperatesOn a8 + , EndoOperatesOn a1 ~ EndoOperatesOn a9 + , EndoOperatesOn a1 ~ EndoOperatesOn a10 + ) => AnEndo (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) + where + type EndoOperatesOn (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = EndoOperatesOn a1 + + anEndo (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = mconcat + [ anEndo a1 + , anEndo a2 + , anEndo a3 + , anEndo a4 + , anEndo a5 + , anEndo a6 + , anEndo a7 + , anEndo a8 + , anEndo a9 + , anEndo a10 + ] + + aDualEndo (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = mconcat + [ aDualEndo a1 + , aDualEndo a2 + , aDualEndo a3 + , aDualEndo a4 + , aDualEndo a5 + , aDualEndo a6 + , aDualEndo a7 + , aDualEndo a8 + , aDualEndo a9 + , aDualEndo a10 + ] + +-- }}} Instances For Tuples --------------------------------------------------- +-- }}} AnEndo Type Class ------------------------------------------------------ + +-- {{{ Utility Functions ------------------------------------------------------ + +-- | Variant of function @('Data.Function.$') :: (a -> b) -> a -> b@ from +-- "Data.Function" module, but with fixity as @(&) :: a -> (a -> b) -> b@ +-- function from . +(&$) :: (a -> b) -> a -> b +f &$ a = f a +infixl 1 &$ + +-- | Variant of function +-- @('Data.Functor.<$>') :: 'Data.Functor.Functor' f => (a -> b) -> a -> b@ +-- from "Data.Functor" module, but with fixity as '&$' function. +(<&$>) :: Functor f => (a -> b) -> f a -> f b +(<&$>) = fmap +infixl 1 <&$> + +-- }}} Utility Functions ------------------------------------------------------ + +-- $usageExample +-- +-- Lets define simple application @Config@ data type as: +-- +-- @ +-- data Verbosity = Silent | Normal | Verbose | Annoying +-- deriving (Bounded, Data, Enum, Eq, Ord, Show, Typeable) +-- +-- data Config = Config +-- { _verbosity :: Verbosity +-- , _outputFile :: FilePath +-- } +-- deriving (Show) +-- @ +-- +-- Now lets define setters for @_verbosity@ and @_outputFile@: +-- +-- @ +-- setVerbosity :: Verbosity -> 'Data.Monoid.Endo.E' Config +-- setVerbosity b cfg = cfg{_verbosity = b} +-- +-- setOutputFile :: FilePath -> 'Data.Monoid.Endo.E' Config +-- setOutputFile b cfg = cfg{_outputFile = b} +-- @ +-- +-- Note that 'Data.Monoid.Endo.E' is defined in "Data.Monoid.Endo" module and +-- it looks like: +-- +-- @ +-- type 'Data.Monoid.Endo.E' a = a -> a +-- @ +-- +-- Its purpose is to simplify type signatures. +-- +-- Now lets get to our first example: +-- +-- @ +-- example1 :: 'Data.Monoid.Endo.E' Config +-- example1 = 'Data.Monoid.appEndo' '$' 'foldEndo' +-- '&$' setVerbosity Annoying +-- '&$' setOutputFile \"an.out.put\" +-- @ +-- +-- Above example shows us that it is possible to modify @Config@ as if it was a +-- monoid, but without actually having to state it as such. In practice it is +-- not always possible to define it as 'Monoid' or at least a @Semigroup@. What +-- usually works are endomorphisms, like in this example. +-- +-- Now, 'System.IO.FilePath' has one pathological case, and that is \"\". There +-- is a lot of ways to handle it. Here we will concentrate only few basic +-- techniques to illustrate versatility of our approach. +-- +-- @ +-- -- | Trying to set output file to \"\" will result in keeping original +-- -- value. +-- setOutputFile2 :: FilePath -> 'Data.Monoid.Endo.E' Config +-- setOutputFile2 \"\" = id +-- setOutputFile2 fp = setOutputFile fp +-- +-- example2 :: 'Data.Monoid.Endo.E' Config +-- example2 = 'Data.Monoid.appEndo' $ 'foldEndo' +-- '&$' setVerbosity Annoying +-- '&$' setOutputFile2 \"an.out.put\" +-- @ +-- +-- Same as above, but exploits @instance 'AnEndo' a => 'AnEndo' 'Maybe' a@: +-- +-- @ +-- setOutputFile3 :: FilePath -> Maybe ('Data.Monoid.Endo.E' Config) +-- setOutputFile3 "" = Nothing +-- setOutputFile3 fp = Just $ setOutputFile fp +-- +-- example3 :: 'Data.Monoid.Endo.E' Config +-- example3 = 'Data.Monoid.appEndo' $ 'foldEndo' +-- '&$' setVerbosity Annoying +-- '&$' setOutputFile3 \"an.out.put\" +-- @ +-- +-- Following example uses common pattern of using 'Either' as error reporting +-- monad. This approach can be easily modified for arbitrary error reporting +-- monad. +-- +-- @ +-- setOutputFile4 :: FilePath -> Either String ('Data.Monoid.Endo.E' Config) +-- setOutputFile4 "" = Left \"Output file: Empty file path.\" +-- setOutputFile4 fp = Right $ setOutputFile fp +-- +-- example4 :: Either String ('Data.Monoid.Endo.E' Config) +-- example4 = 'Data.Monoid.appEndo' '<&$>' 'foldEndo' +-- 'Control.Applicative.<*>' 'pure' (setVerbosity Annoying) +-- 'Control.Applicative.<*>' setOutputFile4 \"an.out.put\" +-- @ +-- +-- Notice, that above example uses applicative style. Normally when using this +-- style, for setting record values, one needs to keep in sync order of +-- constructor arguments and order of operations. Using 'foldEndo' (and its +-- dual 'dualFoldEndo') doesn't have this restriction. +-- +-- Instead of setter functions one may want to use lenses (in terms of +-- ): +-- +-- @ +-- verbosity :: Lens' Config Verbosity +-- verbosity = +-- _verbosity 'Data.Function.Between.~@@^>' \\s b -> s{_verbosity = b} +-- +-- outputFile :: Lens' Config FilePath +-- outputFile = +-- _outputFile 'Data.Function.Between.~@@^>' \\s b -> s{_outputFile = b} +-- @ +-- +-- Now setting values of @Config@ would look like: +-- +-- @ +-- example5 :: 'Data.Monoid.Endo.E' Config +-- example5 = 'Data.Monoid.appEndo' $ 'foldEndo' +-- '&$' verbosity .~ Annoying +-- '&$' outputFile .~ \"an.out.put\" +-- @ +-- +-- Probably one of the most interesting things that can be done with this +-- module is following: +-- +-- @ +-- instance 'AnEndo' Verbosity where +-- type 'EndoOperatesOn' Verbosity = Config +-- 'anEndo' = Endo . set verbosity +-- +-- newtype OutputFile = OutputFile FilePath +-- +-- instance 'AnEndo' OutputFile where +-- type 'EndoOperatesOn' OutputFile = Config +-- 'anEndo' (OutputFile fp) = 'Endo' $ outputFile .~ fp +-- +-- example6 :: 'Data.Monoid.Endo.E' Config +-- example6 = 'Data.Monoid.appEndo' $ 'foldEndo' +-- '&$' Annoying +-- '&$' OutputFile \"an.out.put\" +-- @ + +-- $optparseApplicativeExample +-- +-- This is a more complex example that defines parser for +-- +-- built on top of some of the above definitions: +-- +-- @ +-- options :: Parser Config +-- options = 'Control.Monad.Trans.Identity.runIdentityT' $ 'Control.Monad.Endo.runEndo' defaultConfig \<$\> options' +-- where +-- options' :: 'IdentityT' Parser ('Endo' Config) +-- options' = 'foldEndo' +-- \<*\> outputOption -- :: IdentityT Parser (Maybe (E Config)) +-- \<*\> verbosityOption -- :: IdentityT Parser (Maybe (E Config)) +-- \<*\> annoyingFlag -- :: IdentityT Parser (E Config) +-- \<*\> silentFlag -- :: IdentityT Parser (E Config) +-- \<*\> verboseFlag -- :: IdentityT Parser (E Config) +-- +-- defaultConfig :: Config +-- defaultConfig = Config Normal \"\" +-- +-- main :: IO () +-- main = execParser (info options fullDesc) \>\>= print +-- @ +-- +-- Example of running above @main@ function: +-- +-- >>> :main -o an.out.put --annoying +-- Config {_verbosity = Annoying, _outputFile = "an.out.put"} +-- +-- Parsers for individual options and flags are wrapped in 'IdentityT', because +-- there is no @instance 'FoldEndoArgs' r =\> 'FoldEndoArgs' (Parser r)@, but +-- there is @instance 'FoldEndoArgs' r =\> 'FoldEndoArgs' ('IdentityT' r)@. +-- +-- Functions used by the above code: +-- +-- @ +-- outputOption :: 'IdentityT' Parser (Maybe ('Data.Monoid.Endo.E' Config)) +-- outputOption = +-- IdentityT . optional . option (set outputFile \<$\> parseFilePath) +-- $ short \'o\' \<\> long \"output\" \<\> metavar \"FILE\" +-- \<\> help \"Store output in to a FILE.\" +-- where +-- parseFilePath = eitherReader $ \\s -> +-- if null s +-- then Left \"Option argument can not be empty file path.\" +-- else Right s +-- +-- verbosityOption :: 'IdentityT' Parser (Maybe ('Data.Monoid.Endo.E' Config)) +-- verbosityOption = +-- 'IdentityT' . optional . option (set verbosity \<$\> parseVerbosity) +-- $ long \"verbosity\" \<\> metavar \"LEVEL\" \<\> help \"Set verbosity to LEVEL.\" +-- where +-- verbosityToStr = map toLower . Data.showConstr . Data.toConstr +-- verbosityIntValues = [(show $ fromEnum v, v) | v <- [Silent .. Annoying]] +-- verbosityStrValues = +-- ("default", Normal) : [(verbosityToStr v, v) | v <- [Silent .. Annoying]] +-- +-- parseVerbosityError = unwords +-- [ "Verbosity can be only number from interval" +-- , show $ map fromEnum [minBound, maxBound :: Verbosity] +-- , "or one of the following:" +-- , concat . intersperse ", " $ map fst verbosityStrValues +-- ] +-- +-- parseVerbosity = eitherReader $ \s -> +-- case lookup s $ verbosityIntValues ++ verbosityStrValues of +-- Just v -> Right v +-- Nothing -> Left parseVerbosityError +-- +-- annoyingFlag :: 'IdentityT' Parser ('Data.Monoid.Endo.E' Config) +-- annoyingFlag = 'IdentityT' . flag id (verbosity .~ Annoying) +-- $ long \"annoying\" \<\> help \"Set verbosity to maximum.\" +-- +-- silentFlag :: 'IdentityT' Parser ('Data.Monoid.Endo.E' Config) +-- silentFlag = 'IdentityT' . flag id (verbosity .~ Silent) +-- $ short 's' \<\> long "silent" \<\> help \"Set verbosity to minimum.\" +-- +-- verboseFlag :: 'IdentityT' Parser ('Data.Monoid.Endo.E' Config) +-- verboseFlag = 'IdentityT' . flag id (verbosity .~ Verbose) +-- $ short 'v' \<\> long \"verbose\" \<\> help \"Be verbose.\" +-- @