{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}

-- |
-- Module: Configuration.Utils.Interal
-- Description: Internal utilities of the configuration-tools package
-- Copyright: Copyright © 2014-2015 PivotCloud, Inc.
-- License: MIT
-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>
-- Stability: experimental
--
module Configuration.Utils.Internal
(
-- * Lenses
  lens
, over
, set
, view
, Lens'
, Lens
, Iso'
, Iso
, iso

-- * Misc Utils
, (&)
, (<&>)
, sshow
, exceptT
, errorT
) where

import Control.Applicative (Const(..))
import Control.Monad
import Control.Monad.Reader.Class
import Control.Monad.Except

import Data.Function ((&))
import Data.Functor ((<&>))
import Data.Functor.Identity
import Data.Monoid.Unicode
import Data.Profunctor
import Data.Profunctor.Unsafe
import Data.String
import qualified Data.Text as T

import Prelude.Unicode

-- -------------------------------------------------------------------------- --
-- Lenses

-- Just what we need of van Laarhoven Lenses
--
-- These few lines of code do safe us a lot of dependencies

-- | This is the same type as the type from the lens library with the same name.
--
-- In case it is already import from the lens package this should be hidden
-- from the import.
--
type Lens s t a b = ∀ f . Functor f ⇒ (a → f b) → s → f t

-- | This is the same type as the type from the lens library with the same name.
--
-- In case it is already import from the lens package this should be hidden
-- from the import.
--
type Lens' s a = Lens s s a a

lens ∷ (s → a) → (s → b → t) → Lens s t a b
lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lens s -> a
getter s -> b -> t
setter a -> f b
lGetter s
s = s -> b -> t
setter s
s (b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` a -> f b
lGetter (s -> a
getter s
s)
{-# INLINE lens #-}

over ∷ ((a → Identity b) → s → Identity t) → (a → b) → s → t
over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t
over (a -> Identity b) -> s -> Identity t
s a -> b
f = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> (s -> Identity t) -> s -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity b) -> s -> Identity t
s (b -> Identity b
forall a. a -> Identity a
Identity (b -> Identity b) -> (a -> b) -> a -> Identity b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)
{-# INLINE over #-}

set ∷ ((a → Identity b) → s → Identity t) → b → s → t
set :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
set (a -> Identity b) -> s -> Identity t
s b
a = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> (s -> Identity t) -> s -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity b) -> s -> Identity t
s (Identity b -> a -> Identity b
forall a b. a -> b -> a
const (Identity b -> a -> Identity b) -> Identity b -> a -> Identity b
forall a b. (a -> b) -> a -> b
$ b -> Identity b
forall a. a -> Identity a
Identity b
a)
{-# INLINE set #-}

view ∷ MonadReader r m ⇒ ((a → Const a a) → r → Const a r) → m a
view :: ((a -> Const a a) -> r -> Const a r) -> m a
view (a -> Const a a) -> r -> Const a r
l = (r -> a) -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Const a r -> a
forall a k (b :: k). Const a b -> a
getConst (Const a r -> a) -> (r -> Const a r) -> r -> a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. (a -> Const a a) -> r -> Const a r
l a -> Const a a
forall k a (b :: k). a -> Const a b
Const)
{-# INLINE view #-}

-- | This is the same type as the type from the lens library with the same name.
--
-- In case it is already import from the lens package this should be hidden
-- from the import.
--
type Iso s t a b = ∀ p f . (Profunctor p, Functor f) ⇒ p a (f b) → p s (f t)
type Iso' s a = Iso s s a a

iso ∷ (s → a) → (b → t) → Iso s t a b
iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso s -> a
f b -> t
g = (s -> a) -> (f b -> f t) -> p a (f b) -> p s (f t)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> a
f ((b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
g)
{-# INLINE iso #-}

-- -------------------------------------------------------------------------- --
-- Misc Utils

sshow
    ∷ (Show a, IsString s)
    ⇒ a
    → s
sshow :: a -> s
sshow = String -> s
forall a. IsString a => String -> a
fromString (String -> s) -> (a -> String) -> a -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ a -> String
forall a. Show a => a -> String
show
{-# INLINE sshow #-}

exceptT
    ∷ Monad m
    ⇒ (e → m b)
    → (a → m b)
    → ExceptT e m a
    → m b
exceptT :: (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
exceptT e -> m b
a a -> m b
b = ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e m a -> m (Either e a))
-> (Either e a -> m b) -> ExceptT e m a -> m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (e -> m b) -> (a -> m b) -> Either e a -> m b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> m b
a a -> m b
b
{-# INLINE exceptT #-}

errorT
    ∷ Monad m
    ⇒ ExceptT T.Text m a
    → m a
errorT :: ExceptT Text m a -> m a
errorT = (Text -> m a) -> (a -> m a) -> ExceptT Text m a -> m a
forall (m :: * -> *) e b a.
Monad m =>
(e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
exceptT (\Text
e → String -> m a
forall a. HasCallStack => String -> a
error (String -> m a) -> (Text -> String) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ Text -> String
T.unpack (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$ Text
"Error: " Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
e) a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
{-# INLINE errorT #-}