module Env.Generic
( Record(..)
, Field(..)
, (?)(..)
, G.Generic
) where
import Control.Applicative (liftA2, (<|>))
import Control.Monad (guard)
import qualified Data.Char as Char
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Word (Word8, Word16, Word32, Word64)
import qualified Data.List as List
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy(Proxy))
import qualified GHC.Generics as G
import qualified GHC.TypeLits as G
import Numeric.Natural (Natural)
import Prelude hiding (mod)
import qualified Env
class Record e a where
record :: Env.Parser e a
default record :: (r ~ G.Rep a, G.Generic a, GRecord e r) => Env.Parser e a
record =
fmap G.to (gr State {statePrefix="", stateCon="", stateVar=""})
data State = State
{ statePrefix :: String
, stateCon :: String
, stateVar :: String
} deriving (Show, Eq)
class GRecord e f where
gr :: State -> Env.Parser e (f a)
instance GRecord e a => GRecord e (G.D1 c a) where
gr =
fmap G.M1 . gr
instance (Env.AsUnset e, Field e a) => GRecord e (G.K1 i a) where
gr State {stateVar} =
fmap G.K1 (field stateVar Nothing)
instance (G.Constructor c, GRecord e a) => GRecord e (G.C1 c a) where
gr state =
fmap G.M1 (gr state {stateCon=con})
where
con = G.conName (G.M1 Proxy :: G.M1 t c Proxy b)
instance (GRecord e f, GRecord e g) => GRecord e (f G.:*: g) where
gr x =
liftA2 (G.:*:) (gr x) (gr x)
instance (GRecord e f, GRecord e g) => GRecord e (f G.:+: g) where
gr x =
fmap G.L1 (gr x) <|> fmap G.R1 (gr x)
instance (G.Selector c, Type c ~ 'Record, GRecord e a) => GRecord e (G.S1 c a) where
gr state@State {statePrefix, stateCon} =
fmap G.M1 (gr state {stateVar=statePrefix ++ suffix})
where
sel = G.selName (G.M1 Proxy :: G.M1 t c Proxy b)
suffix = let
x = camelTo2 sel
in fromMaybe x $ do
y <- List.stripPrefix (map Char.toLower stateCon) sel
camelTo2 y <$ guard (not (List.null y))
camelTo2 :: String -> String
camelTo2 = map Char.toUpper . go2 . go1
where
go1 "" = ""
go1 (x:u:l:xs) | Char.isUpper u && Char.isLower l = x : '_' : u : l : go1 xs
go1 (x:xs) = x : go1 xs
go2 "" = ""
go2 (l:u:xs) | Char.isLower l && Char.isUpper u = l : '_' : u : go2 xs
go2 (x:xs) = x : go2 xs
type family Type x :: ConType where
Type G.NoSelector = 'Plain
Type x = 'Record
data ConType = Plain | Record
class Field e a where
field :: String -> Maybe String -> Env.Parser e a
default field :: (Env.AsUnset e, Env.AsUnread e, Read a) => String -> Maybe String -> Env.Parser e a
field name help =
Env.var Env.auto name (foldMap Env.help help)
instance (Env.AsUnset e, Env.AsUnread e) => Field e Int
instance (Env.AsUnset e, Env.AsUnread e) => Field e Int8
instance (Env.AsUnset e, Env.AsUnread e) => Field e Int16
instance (Env.AsUnset e, Env.AsUnread e) => Field e Int32
instance (Env.AsUnset e, Env.AsUnread e) => Field e Int64
instance (Env.AsUnset e, Env.AsUnread e) => Field e Integer
instance (Env.AsUnset e, Env.AsUnread e) => Field e Word
instance (Env.AsUnset e, Env.AsUnread e) => Field e Word8
instance (Env.AsUnset e, Env.AsUnread e) => Field e Word16
instance (Env.AsUnset e, Env.AsUnread e) => Field e Word32
instance (Env.AsUnset e, Env.AsUnread e) => Field e Word64
instance (Env.AsUnset e, Env.AsUnread e) => Field e Natural
instance (Env.AsUnset e, Env.AsUnread e) => Field e Float
instance (Env.AsUnset e, Env.AsUnread e) => Field e Double
instance Env.AsUnset e => Field e String where
field name help =
Env.var Env.str name (foldMap Env.help help)
instance (Env.AsUnset e, Env.AsUnread e) => Field e Char where
field name help =
Env.var reader name (foldMap Env.help help)
where
reader = \case
[c] -> pure c
str -> Left (Env.unread str)
instance (Env.AsUnset e, Env.AsEmpty e) => Field e Bool where
field name help =
Env.switch name (foldMap Env.help help)
newtype a ? tag = Help { unHelp :: a }
deriving (Show, Eq, Functor, Foldable, Traversable)
instance (G.KnownSymbol tag, Field e a) => Field e (a ? tag) where
field name _ =
fmap Help (field name (pure (G.symbolVal (Proxy :: Proxy tag))))