{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}

-- |
-- Module: Configuration.Utils.Monoid
-- Description: Configuration of Monoids
-- Copyright: Copyright © 2015 PivotCloud, Inc.
-- License: MIT
-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>
-- Stability: experimental
--
-- The distinction between appending on the left and appending on the right is
-- important for monoids that are sensitive to ordering such as 'List'. It is
-- also of relevance for monoids with set semantics with non-extensional
-- equality such as `HashMap`.
--
module Configuration.Utils.Monoid
  ( LeftMonoidalUpdate
  , leftMonoidalUpdate
  , fromLeftMonoidalUpdate
  , pLeftMonoidalUpdate
  , pLeftSemigroupalUpdate
  , RightMonoidalUpdate
  , rightMonoidalUpdate
  , fromRightMonoidalUpdate
  , pRightMonoidalUpdate
  , pRightSemigroupalUpdate
  ) where

import Configuration.Utils.CommandLine
import Configuration.Utils.Internal

import Control.Monad.Writer hiding (mapM_, (<>))

import Data.Aeson
import qualified Data.List.NonEmpty as NEL
import Data.Semigroup
import Data.Semigroup.Foldable (fold1)

import qualified Options.Applicative.Types as O

import Prelude hiding (any, concatMap, mapM_)
import Prelude.Unicode

-- | Update a value by appending on the left. Under normal
-- circumstances you'll never use this type directly but only
-- its 'FromJSON' instance. See the 'leftMonoidalUpdate' for an example.
--
newtype LeftMonoidalUpdate a = LeftMonoidalUpdate
    { LeftMonoidalUpdate a -> a
_getLeftMonoidalUpdate ∷ a
    }
    deriving (b -> LeftMonoidalUpdate a -> LeftMonoidalUpdate a
NonEmpty (LeftMonoidalUpdate a) -> LeftMonoidalUpdate a
LeftMonoidalUpdate a
-> LeftMonoidalUpdate a -> LeftMonoidalUpdate a
(LeftMonoidalUpdate a
 -> LeftMonoidalUpdate a -> LeftMonoidalUpdate a)
-> (NonEmpty (LeftMonoidalUpdate a) -> LeftMonoidalUpdate a)
-> (forall b.
    Integral b =>
    b -> LeftMonoidalUpdate a -> LeftMonoidalUpdate a)
-> Semigroup (LeftMonoidalUpdate a)
forall b.
Integral b =>
b -> LeftMonoidalUpdate a -> LeftMonoidalUpdate a
forall a.
Semigroup a =>
NonEmpty (LeftMonoidalUpdate a) -> LeftMonoidalUpdate a
forall a.
Semigroup a =>
LeftMonoidalUpdate a
-> LeftMonoidalUpdate a -> LeftMonoidalUpdate a
forall a b.
(Semigroup a, Integral b) =>
b -> LeftMonoidalUpdate a -> LeftMonoidalUpdate a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> LeftMonoidalUpdate a -> LeftMonoidalUpdate a
$cstimes :: forall a b.
(Semigroup a, Integral b) =>
b -> LeftMonoidalUpdate a -> LeftMonoidalUpdate a
sconcat :: NonEmpty (LeftMonoidalUpdate a) -> LeftMonoidalUpdate a
$csconcat :: forall a.
Semigroup a =>
NonEmpty (LeftMonoidalUpdate a) -> LeftMonoidalUpdate a
<> :: LeftMonoidalUpdate a
-> LeftMonoidalUpdate a -> LeftMonoidalUpdate a
$c<> :: forall a.
Semigroup a =>
LeftMonoidalUpdate a
-> LeftMonoidalUpdate a -> LeftMonoidalUpdate a
Semigroup, Semigroup (LeftMonoidalUpdate a)
LeftMonoidalUpdate a
Semigroup (LeftMonoidalUpdate a)
-> LeftMonoidalUpdate a
-> (LeftMonoidalUpdate a
    -> LeftMonoidalUpdate a -> LeftMonoidalUpdate a)
-> ([LeftMonoidalUpdate a] -> LeftMonoidalUpdate a)
-> Monoid (LeftMonoidalUpdate a)
[LeftMonoidalUpdate a] -> LeftMonoidalUpdate a
LeftMonoidalUpdate a
-> LeftMonoidalUpdate a -> LeftMonoidalUpdate a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. Monoid a => Semigroup (LeftMonoidalUpdate a)
forall a. Monoid a => LeftMonoidalUpdate a
forall a.
Monoid a =>
[LeftMonoidalUpdate a] -> LeftMonoidalUpdate a
forall a.
Monoid a =>
LeftMonoidalUpdate a
-> LeftMonoidalUpdate a -> LeftMonoidalUpdate a
mconcat :: [LeftMonoidalUpdate a] -> LeftMonoidalUpdate a
$cmconcat :: forall a.
Monoid a =>
[LeftMonoidalUpdate a] -> LeftMonoidalUpdate a
mappend :: LeftMonoidalUpdate a
-> LeftMonoidalUpdate a -> LeftMonoidalUpdate a
$cmappend :: forall a.
Monoid a =>
LeftMonoidalUpdate a
-> LeftMonoidalUpdate a -> LeftMonoidalUpdate a
mempty :: LeftMonoidalUpdate a
$cmempty :: forall a. Monoid a => LeftMonoidalUpdate a
$cp1Monoid :: forall a. Monoid a => Semigroup (LeftMonoidalUpdate a)
Monoid)

-- | Update a value by appending on the left.
--
-- > newtype RoutingTable = RoutingTable { _routingTableMap ∷ HashMap T.Text T.Text }
-- >
-- > $(makeLenses ''RoutingTable)
-- >
-- > instance FromJSON (RoutingTable → RoutingTable) where
-- >     parseJSON = withObject "RoutingTable" $ \o → id
-- >         <$< routingTableMap . from leftMonoidalUpdate %.: "route_map" % o
--
leftMonoidalUpdate ∷ Iso (LeftMonoidalUpdate a) (LeftMonoidalUpdate b) a b
leftMonoidalUpdate :: p a (f b) -> p (LeftMonoidalUpdate a) (f (LeftMonoidalUpdate b))
leftMonoidalUpdate = (LeftMonoidalUpdate a -> a)
-> (b -> LeftMonoidalUpdate b)
-> Iso (LeftMonoidalUpdate a) (LeftMonoidalUpdate b) a b
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso LeftMonoidalUpdate a -> a
forall a. LeftMonoidalUpdate a -> a
_getLeftMonoidalUpdate b -> LeftMonoidalUpdate b
forall a. a -> LeftMonoidalUpdate a
LeftMonoidalUpdate

-- | This is the same as @from leftMonoidalUpdate@ but doesn't depend on
-- the lens Library.
--
fromLeftMonoidalUpdate ∷ Iso a b (LeftMonoidalUpdate a) (LeftMonoidalUpdate b)
fromLeftMonoidalUpdate :: p (LeftMonoidalUpdate a) (f (LeftMonoidalUpdate b)) -> p a (f b)
fromLeftMonoidalUpdate = (a -> LeftMonoidalUpdate a)
-> (LeftMonoidalUpdate b -> b)
-> Iso a b (LeftMonoidalUpdate a) (LeftMonoidalUpdate b)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso a -> LeftMonoidalUpdate a
forall a. a -> LeftMonoidalUpdate a
LeftMonoidalUpdate LeftMonoidalUpdate b -> b
forall a. LeftMonoidalUpdate a -> a
_getLeftMonoidalUpdate

instance (FromJSON a, Monoid a) ⇒ FromJSON (LeftMonoidalUpdate a → LeftMonoidalUpdate a) where
    parseJSON :: Value -> Parser (LeftMonoidalUpdate a -> LeftMonoidalUpdate a)
parseJSON = (a -> LeftMonoidalUpdate a -> LeftMonoidalUpdate a)
-> Parser a
-> Parser (LeftMonoidalUpdate a -> LeftMonoidalUpdate a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LeftMonoidalUpdate a
-> LeftMonoidalUpdate a -> LeftMonoidalUpdate a
forall a. Monoid a => a -> a -> a
mappend (LeftMonoidalUpdate a
 -> LeftMonoidalUpdate a -> LeftMonoidalUpdate a)
-> (a -> LeftMonoidalUpdate a)
-> a
-> LeftMonoidalUpdate a
-> LeftMonoidalUpdate a
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ a -> LeftMonoidalUpdate a
forall a. a -> LeftMonoidalUpdate a
LeftMonoidalUpdate) (Parser a -> Parser (LeftMonoidalUpdate a -> LeftMonoidalUpdate a))
-> (Value -> Parser a)
-> Value
-> Parser (LeftMonoidalUpdate a -> LeftMonoidalUpdate a)
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON

-- | Update a value by appending on the left.
--
-- > newtype RoutingTable = RoutingTable { _routingTableMap ∷ HashMap T.Text T.Text }
-- >
-- > $(makeLenses ''RoutingTable)
-- >
-- > pRoutingTable ∷ MParser RoutingTable
-- > pRoutingTable = routingTableMap %:: pLeftMonoidalUpdate pRoute
-- >   where
-- >     pRoute = option (eitherReader readRoute)
-- >         % long "route"
-- >         <> help "add a route to the routing table; the APIROUTE part must not contain a colon character"
-- >         <> metavar "APIROUTE:APIURL"
-- >
-- >     readRoute s = case break (== ':') s of
-- >         (a,':':b) → first T.unpack $ do
-- >             validateNonEmpty "APIROUTE" a
-- >             validateHttpOrHttpsUrl "APIURL" b
-- >             return $ HM.singleton (T.pack a) (T.pack b)
-- >         _ → Left "missing colon between APIROUTE and APIURL"
-- >
-- >     first f = either (Left . f) Right
--
pLeftMonoidalUpdate ∷ Monoid a ⇒ O.Parser a → MParser a
pLeftMonoidalUpdate :: Parser a -> MParser a
pLeftMonoidalUpdate Parser a
pElement = a -> a -> a
forall a. Monoid a => a -> a -> a
mappend (a -> a -> a) -> ([a] -> a) -> [a] -> a -> a
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ [a] -> a
forall a. Monoid a => [a] -> a
mconcat ([a] -> a) -> ([a] -> [a]) -> [a] -> a
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> a -> a) -> Parser [a] -> MParser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser a
pElement

-- | Like `pLeftMonoidalUpdate`, but works for `Semigroup`s instead. Using this
-- parser requires the input to have at least one copy (say, for flags that can
-- be passed multiple times).
--
pLeftSemigroupalUpdate ∷ Semigroup a ⇒ O.Parser a → MParser a
pLeftSemigroupalUpdate :: Parser a -> MParser a
pLeftSemigroupalUpdate Parser a
pElement = a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>) (a -> a -> a) -> ([a] -> a) -> [a] -> a -> a
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ NonEmpty a -> a
forall (t :: * -> *) m. (Foldable1 t, Semigroup m) => t m -> m
fold1 (NonEmpty a -> a) -> ([a] -> NonEmpty a) -> [a] -> a
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ [a] -> NonEmpty a
forall a. [a] -> NonEmpty a
NEL.fromList ([a] -> NonEmpty a) -> ([a] -> [a]) -> [a] -> NonEmpty a
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> a -> a) -> Parser [a] -> MParser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Parser a
pElement

-- | Update a value by appending on the right. Under normal
-- circumstances you'll never use this type directly but only
-- its 'FromJSON' instance. See the 'leftMonoidalUpdate' for an example.
--
newtype RightMonoidalUpdate a = RightMonoidalUpdate
    { RightMonoidalUpdate a -> a
_getRightMonoidalUpdate ∷ a
    }
    deriving (b -> RightMonoidalUpdate a -> RightMonoidalUpdate a
NonEmpty (RightMonoidalUpdate a) -> RightMonoidalUpdate a
RightMonoidalUpdate a
-> RightMonoidalUpdate a -> RightMonoidalUpdate a
(RightMonoidalUpdate a
 -> RightMonoidalUpdate a -> RightMonoidalUpdate a)
-> (NonEmpty (RightMonoidalUpdate a) -> RightMonoidalUpdate a)
-> (forall b.
    Integral b =>
    b -> RightMonoidalUpdate a -> RightMonoidalUpdate a)
-> Semigroup (RightMonoidalUpdate a)
forall b.
Integral b =>
b -> RightMonoidalUpdate a -> RightMonoidalUpdate a
forall a.
Semigroup a =>
NonEmpty (RightMonoidalUpdate a) -> RightMonoidalUpdate a
forall a.
Semigroup a =>
RightMonoidalUpdate a
-> RightMonoidalUpdate a -> RightMonoidalUpdate a
forall a b.
(Semigroup a, Integral b) =>
b -> RightMonoidalUpdate a -> RightMonoidalUpdate a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> RightMonoidalUpdate a -> RightMonoidalUpdate a
$cstimes :: forall a b.
(Semigroup a, Integral b) =>
b -> RightMonoidalUpdate a -> RightMonoidalUpdate a
sconcat :: NonEmpty (RightMonoidalUpdate a) -> RightMonoidalUpdate a
$csconcat :: forall a.
Semigroup a =>
NonEmpty (RightMonoidalUpdate a) -> RightMonoidalUpdate a
<> :: RightMonoidalUpdate a
-> RightMonoidalUpdate a -> RightMonoidalUpdate a
$c<> :: forall a.
Semigroup a =>
RightMonoidalUpdate a
-> RightMonoidalUpdate a -> RightMonoidalUpdate a
Semigroup, Semigroup (RightMonoidalUpdate a)
RightMonoidalUpdate a
Semigroup (RightMonoidalUpdate a)
-> RightMonoidalUpdate a
-> (RightMonoidalUpdate a
    -> RightMonoidalUpdate a -> RightMonoidalUpdate a)
-> ([RightMonoidalUpdate a] -> RightMonoidalUpdate a)
-> Monoid (RightMonoidalUpdate a)
[RightMonoidalUpdate a] -> RightMonoidalUpdate a
RightMonoidalUpdate a
-> RightMonoidalUpdate a -> RightMonoidalUpdate a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. Monoid a => Semigroup (RightMonoidalUpdate a)
forall a. Monoid a => RightMonoidalUpdate a
forall a.
Monoid a =>
[RightMonoidalUpdate a] -> RightMonoidalUpdate a
forall a.
Monoid a =>
RightMonoidalUpdate a
-> RightMonoidalUpdate a -> RightMonoidalUpdate a
mconcat :: [RightMonoidalUpdate a] -> RightMonoidalUpdate a
$cmconcat :: forall a.
Monoid a =>
[RightMonoidalUpdate a] -> RightMonoidalUpdate a
mappend :: RightMonoidalUpdate a
-> RightMonoidalUpdate a -> RightMonoidalUpdate a
$cmappend :: forall a.
Monoid a =>
RightMonoidalUpdate a
-> RightMonoidalUpdate a -> RightMonoidalUpdate a
mempty :: RightMonoidalUpdate a
$cmempty :: forall a. Monoid a => RightMonoidalUpdate a
$cp1Monoid :: forall a. Monoid a => Semigroup (RightMonoidalUpdate a)
Monoid)

-- | Update a value by appending on the right. See 'leftMonoidalUpdate' for
-- an usage example.
--
rightMonoidalUpdate ∷ Iso (RightMonoidalUpdate a) (RightMonoidalUpdate b) a b
rightMonoidalUpdate :: p a (f b) -> p (RightMonoidalUpdate a) (f (RightMonoidalUpdate b))
rightMonoidalUpdate = (RightMonoidalUpdate a -> a)
-> (b -> RightMonoidalUpdate b)
-> Iso (RightMonoidalUpdate a) (RightMonoidalUpdate b) a b
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso RightMonoidalUpdate a -> a
forall a. RightMonoidalUpdate a -> a
_getRightMonoidalUpdate b -> RightMonoidalUpdate b
forall a. a -> RightMonoidalUpdate a
RightMonoidalUpdate

-- | This is the same as @from rightMonoidalUpdate@ but doesn't depend on
-- the lens Library.
--
fromRightMonoidalUpdate ∷ Iso a b (RightMonoidalUpdate a) (RightMonoidalUpdate b)
fromRightMonoidalUpdate :: p (RightMonoidalUpdate a) (f (RightMonoidalUpdate b)) -> p a (f b)
fromRightMonoidalUpdate = (a -> RightMonoidalUpdate a)
-> (RightMonoidalUpdate b -> b)
-> Iso a b (RightMonoidalUpdate a) (RightMonoidalUpdate b)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso a -> RightMonoidalUpdate a
forall a. a -> RightMonoidalUpdate a
RightMonoidalUpdate RightMonoidalUpdate b -> b
forall a. RightMonoidalUpdate a -> a
_getRightMonoidalUpdate

instance (FromJSON a, Monoid a) ⇒ FromJSON (RightMonoidalUpdate a → RightMonoidalUpdate a) where
    parseJSON :: Value -> Parser (RightMonoidalUpdate a -> RightMonoidalUpdate a)
parseJSON = (a -> RightMonoidalUpdate a -> RightMonoidalUpdate a)
-> Parser a
-> Parser (RightMonoidalUpdate a -> RightMonoidalUpdate a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RightMonoidalUpdate a
 -> RightMonoidalUpdate a -> RightMonoidalUpdate a)
-> RightMonoidalUpdate a
-> RightMonoidalUpdate a
-> RightMonoidalUpdate a
forall a b c. (a -> b -> c) -> b -> a -> c
flip RightMonoidalUpdate a
-> RightMonoidalUpdate a -> RightMonoidalUpdate a
forall a. Monoid a => a -> a -> a
mappend (RightMonoidalUpdate a
 -> RightMonoidalUpdate a -> RightMonoidalUpdate a)
-> (a -> RightMonoidalUpdate a)
-> a
-> RightMonoidalUpdate a
-> RightMonoidalUpdate a
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ a -> RightMonoidalUpdate a
forall a. a -> RightMonoidalUpdate a
RightMonoidalUpdate) (Parser a
 -> Parser (RightMonoidalUpdate a -> RightMonoidalUpdate a))
-> (Value -> Parser a)
-> Value
-> Parser (RightMonoidalUpdate a -> RightMonoidalUpdate a)
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON

-- | Update a value by appending on the right. See 'pLeftMonoidalUpdate'
-- for an usage example.
--
pRightMonoidalUpdate ∷ Monoid a ⇒ O.Parser a → MParser a
pRightMonoidalUpdate :: Parser a -> MParser a
pRightMonoidalUpdate Parser a
pElement = (a -> a -> a) -> a -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> a -> a
forall a. Monoid a => a -> a -> a
mappend (a -> a -> a) -> ([a] -> a) -> [a] -> a -> a
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ [a] -> a
forall a. Monoid a => [a] -> a
mconcat ([a] -> a -> a) -> Parser [a] -> MParser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser a
pElement

-- | Like `pRightMonoidalUpdate`, but works for `Semigroup`s instead. Using this
-- parser requires the input to have at least one copy (say, for flags that can
-- be passed multiple times).
--
pRightSemigroupalUpdate ∷ Semigroup a ⇒ O.Parser a → MParser a
pRightSemigroupalUpdate :: Parser a -> MParser a
pRightSemigroupalUpdate Parser a
pElement = (a -> a -> a) -> a -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>) (a -> a -> a) -> ([a] -> a) -> [a] -> a -> a
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ NonEmpty a -> a
forall (t :: * -> *) m. (Foldable1 t, Semigroup m) => t m -> m
fold1 (NonEmpty a -> a) -> ([a] -> NonEmpty a) -> [a] -> a
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ [a] -> NonEmpty a
forall a. [a] -> NonEmpty a
NEL.fromList ([a] -> a -> a) -> Parser [a] -> MParser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Parser a
pElement