{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Config.Simple
( ConfigBool
, ConfigLast
, ConfigSet
, Partial
, Complete
, LensFor(..)
, AccumFor(..)
, configLens
, configLensPartial
, fromPartialConfig
) where
import Control.Lens
import Data.Either.Validation
import Data.Monoid (Any(..), Last(..))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String (IsString(..))
import GHC.Generics
import qualified GHC.Generics as G
import qualified GHC.Generics.Lens as G
import Control.Applicative
data CPartial
data CComplete
data CAccum
data CLensFor k c
type family ConfigLensTarget k where
ConfigLensTarget CComplete = CComplete
ConfigLensTarget CPartial = CAccum
type family ConfigLensFor k s a where
ConfigLensFor CComplete s a = LensFor s a
ConfigLensFor CPartial s a = AccumFor s a
newtype LensFor s a =
LensFor (Lens' s a)
newtype AccumFor s a =
AccumFor (a -> s -> s)
type family ConfigLast a k where
ConfigLast a CPartial = Last a
ConfigLast a CComplete = a
ConfigLast a CAccum = a
ConfigLast a (CLensFor k root) = ConfigLensFor k root (ConfigLast a (ConfigLensTarget k))
type family ConfigBool k where
ConfigBool CPartial = Any
ConfigBool CComplete = Bool
ConfigBool CAccum = Bool
ConfigBool (CLensFor k root) = ConfigLensFor k root (ConfigBool (ConfigLensTarget k))
type family ConfigSet a k where
ConfigSet a CPartial = Set a
ConfigSet a CComplete = Set a
ConfigSet a CAccum = a
ConfigSet a (CLensFor k root) = ConfigLensFor k root (ConfigSet a (ConfigLensTarget k))
type Partial config = config CPartial
type Complete config = config CComplete
type LensConfig k config = config (CLensFor k (config k))
fromPartialConfig ::
( Generic (Partial config)
, Generic (Complete config)
, GFromPartialConfig (Rep (Partial config)) (Rep (Complete config))
, IsString text
)
=> Partial config
-> Validation [text] (Complete config)
fromPartialConfig = fmap G.to . gFromPartialConfig . G.from
class GFromPartialConfig (repPartial :: * -> *) (repComplete :: * -> *) where
gFromPartialConfig :: IsString text => repPartial x -> Validation [text] (repComplete x)
instance GFromPartialConfig fp fc =>
GFromPartialConfig (D1 m fp) (D1 m fc) where
gFromPartialConfig (M1 x) = M1 <$> gFromPartialConfig x
instance GFromPartialConfig fp fc =>
GFromPartialConfig (C1 m fp) (C1 m fc) where
gFromPartialConfig (M1 x) = M1 <$> gFromPartialConfig x
instance (GFromPartialConfig ap ac, GFromPartialConfig bp bc) =>
GFromPartialConfig (ap :*: bp) (ac :*: bc) where
gFromPartialConfig (a :*: b) =
liftA2 (:*:) (gFromPartialConfig a) (gFromPartialConfig b)
instance (GFromPartialConfigMaybe fp fc, Selector m) =>
GFromPartialConfig (S1 m fp) (S1 m fc) where
gFromPartialConfig v@(M1 x) =
fmap M1 $
case gFromPartialConfigMaybe x of
Just r -> Success r
Nothing -> Failure [fromString $ selName v]
class GFromPartialConfigMaybe (repPartial :: * -> *) (repComplete :: * -> *) where
gFromPartialConfigMaybe :: repPartial x -> Maybe (repComplete x)
class GFromPartialConfigMember partial complete where
gFromPartialConfigMember :: partial -> Maybe complete
instance GFromPartialConfigMember partial complete =>
GFromPartialConfigMaybe (Rec0 partial) (Rec0 complete) where
gFromPartialConfigMaybe (K1 a) = K1 <$> gFromPartialConfigMember a
instance GFromPartialConfigMember Any Bool where
gFromPartialConfigMember = Just . getAny
instance GFromPartialConfigMember (Set a) (Set a) where
gFromPartialConfigMember = Just
instance GFromPartialConfigMember (Last a) a where
gFromPartialConfigMember = getLast
configLens' ::
forall config k.
( Generic (config k)
, Generic (LensConfig k config)
, GLensFor (config k) (Rep (config k)) (Rep (LensConfig k config))
)
=> LensConfig k config
configLens' = G.to $ gToLensFor rootLens
where
rootLens ::
forall x. Generic (config k)
=> Lens' (config k) (Rep (config k) x)
rootLens = G.generic
configLens ::
forall config.
( Generic (config CComplete)
, Generic (LensConfig CComplete config)
, GLensFor (config CComplete) (Rep (config CComplete)) (Rep (LensConfig CComplete config))
)
=> LensConfig CComplete config
configLens = configLens'
configLensPartial ::
forall config.
( Generic (config CPartial)
, Generic (LensConfig CPartial config)
, GLensFor (config CPartial) (Rep (config CPartial)) (Rep (LensConfig CPartial config))
)
=> LensConfig CPartial config
configLensPartial = configLens'
class GLensFor root rep repLens where
gToLensFor :: Lens' root (rep x) -> repLens x
instance GLensFor root r rl => GLensFor root (M1 i m r) (M1 i m rl) where
gToLensFor rootLens = M1 $ gToLensFor (rootLens . G._M1)
instance (GLensFor root ra ral, GLensFor root rb rbl) =>
GLensFor root (ra :*: rb) (ral :*: rbl) where
gToLensFor rootLens =
gToLensFor (rootLens . _1) :*: gToLensFor (rootLens . _2)
instance GLensFor root (Rec0 x) (Rec0 (LensFor root x)) where
gToLensFor rootLens = K1 $ LensFor $ rootLens . G._K1
instance GLensFor root (Rec0 (Last x)) (Rec0 (AccumFor root x)) where
gToLensFor rootLens = K1 $ AccumFor $ \v s -> s & rootLens . G._K1 <>~ Last (Just v)
instance GLensFor root (Rec0 Any) (Rec0 (AccumFor root Bool)) where
gToLensFor rootLens = K1 $ AccumFor $ \v s -> s & rootLens . G._K1 <>~ Any v
instance Ord a => GLensFor root (Rec0 (Set a)) (Rec0 (AccumFor root a)) where
gToLensFor rootLens = K1 $ AccumFor $ \v s -> s & rootLens . G._K1 <>~ Set.singleton v