liblawless-0.26.0: Source/Environment.hs

{-# Language TemplateHaskell #-}

{-|
Module:             Environment
Description:        Execution environment, but as Text and lifted to MonadIO.
Copyright:          © 2017 All rights reserved.
License:            GPL-3
Maintainer:         Evan Cofsky <evan@theunixman.com>
Stability:          experimental
Portability:        POSIX
-}

module Environment (
    EnvName,
    _EnvName,

    EnvValue,
    _EnvValue,

    environment,

    Arg,
    _Arg,
    args,

    ProgName,
    _ProgName,
    progName
    )where

import Lawless

import qualified System.Environment as SE

-- | A key in the 'Environment'.
newtype EnvName = EnvName Text deriving (Eq, Ord, Show, Printable)
makePrisms ''EnvName

instance IsText EnvName where
    packed = iso (EnvName ∘ view packed) (view unpacked ∘ view _EnvName)
    builder = iso (view builder ∘ view _EnvName) (EnvName ∘ review builder)

-- | A value in the 'Environment'
newtype EnvValue = EnvValue Text deriving (Eq, Ord, Show, Printable)
makePrisms ''EnvValue

instance IsText EnvValue where
    packed = iso (EnvValue ∘ view packed) (view unpacked ∘ view _EnvValue)
    builder = iso (view builder ∘ view _EnvValue) (EnvValue ∘ review builder)

lookupEnv ∷ MonadIO m ⇒ EnvName → m (Maybe EnvValue)
lookupEnv k =
    liftIO $ maybe Nothing (Just ∘ EnvValue ∘ view packed)
    <$> SE.lookupEnv (k ^. unpacked)

setEnv ∷ MonadIO m ⇒ EnvName → EnvValue → m ()
setEnv k v = liftIO $ SE.setEnv (k ^. unpacked) (v ^. unpacked)

-- | 'Lens' for the system environment.
--
--
-- lens ∷ Functor f => (s -> a) -> (s -> b -> t) -> (a -> f b) -> s -> f t
--
--
-- Lens s t a b = Functor f ⇒ (a → f b) → s → f t
--
-- 'lookupEnv'
-- s → a: EnvName → m (Maybe EnvValue)
--
-- 'setEnv'
-- s → b → t: EnvName → EnvValue → m ()
--
-- s: EnvName
-- t: m ()
-- a: m (Maybe EnvValue)
-- b: EnvValue
environment ∷ MonadIO m ⇒ Lens EnvName (m ()) (m (Maybe EnvValue)) EnvValue
environment = lens lookupEnv setEnv

newtype Arg = Arg Text deriving (Eq, Show, Ord, Printable)
makePrisms ''Arg

instance IsText Arg where
    packed = iso (Arg ∘ view packed) (view unpacked ∘ view _Arg)
    builder = iso (view builder ∘ view _Arg) (Arg ∘ review builder)

args ∷ (MonadIO m) ⇒ m [Arg]
args = liftIO $ over traversed (view packed) <$> SE.getArgs

newtype ProgName = ProgName Text deriving (Eq, Show, Ord, Printable)
makePrisms ''ProgName

instance IsText ProgName where
    packed = iso (ProgName ∘ view packed) (view unpacked ∘ view _ProgName)
    builder = iso (view builder ∘ view _ProgName) (ProgName ∘ review builder)

progName ∷ (MonadIO m) ⇒ m ProgName
progName = liftIO $ view packed <$> SE.getProgName