liblawless-0.21.0: Source/Environment.hs

{-|
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 where

import Lawless
import IO
import Text
import Textual

import qualified System.Environment as SE

-- | A key in the 'Environment'.
newtype EnvName = EnvName {unEnvName ∷ Text} deriving (Eq, Ord, Show, Printable)
instance IsText EnvName where
    packed = iso (EnvName ∘ view packed) (view unpacked ∘ unEnvName)
    builder = iso (view builder ∘ unEnvName) (EnvName ∘ review builder)

-- | A value in the 'Environment'
newtype EnvValue = EnvValue {unEnvValue ∷ Text} deriving (Eq, Ord, Show, Printable)
instance IsText EnvValue where
    packed = iso (EnvValue ∘ view packed) (view unpacked ∘ unEnvValue)
    builder = iso (view builder ∘ unEnvValue) (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 {unArg ∷ Text} deriving (Eq, Show, Ord, Printable)
instance IsText Arg where
    packed = iso (Arg ∘ view packed) (view unpacked ∘ unArg)
    builder = iso (view builder ∘ unArg) (Arg ∘ review builder)

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

newtype ProgName = ProgName {unProgName ∷ Text} deriving (Eq, Show, Ord, Printable)
instance IsText ProgName where
    packed = iso (ProgName ∘ view packed) (view unpacked ∘ unProgName)
    builder = iso (view builder ∘ unProgName) (ProgName ∘ review builder)

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