module B9.Environment
( Environment()
, fromStringPairs
, addBinding
, addStringBinding
, addLocalStringBinding
, addPositionalArguments
, addLocalPositionalArguments
, EnvironmentReader
, hasKey
, runEnvironmentReader
, askEnvironment
, localEnvironment
, lookupOrThrow
, lookupEither
, KeyNotFound(..)
, DuplicateKey(..)
)
where
import B9.B9Error
import B9.Text
import Control.Arrow ( (***) )
import Control.Exception ( Exception )
import Control.Eff as Eff
import Control.Eff.Reader.Lazy as Eff
import Control.Parallel.Strategies
import Data.Data
import Data.Foldable
import Data.HashMap.Strict ( HashMap )
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe ( maybe
, isJust
)
import GHC.Generics ( Generic )
data Environment = MkEnvironment
{ nextPosition :: Int
, fromEnvironment :: HashMap Text Text
} deriving (Show, Typeable, Data, Eq, Generic)
instance NFData Environment
instance Semigroup Environment where
e1 <> e2 = MkEnvironment
{ nextPosition = case (nextPosition e1, nextPosition e2) of
(1 , 1 ) -> 1
(1 , p2) -> p2
(p1, 1 ) -> p1
_ -> error
( "Overlapping positional arguments (<>): ("
++ show e1
++ ") <> ("
++ show e2
++ ")"
)
, fromEnvironment = let i = HashMap.intersection h1 h2
h1 = fromEnvironment e1
h2 = fromEnvironment e2
in if HashMap.null i || all
(\k -> HashMap.lookup k h1 == HashMap.lookup k h2
)
(HashMap.keys i)
then
h1 <> h2
else
error
( "Overlapping entries (<>): ("
++ show e1
++ ") <> ("
++ show e2
++ "): ("
++ show i
++ ")"
)
}
instance Monoid Environment where
mempty = MkEnvironment 1 HashMap.empty
addPositionalArguments :: [Text] -> Environment -> Environment
addPositionalArguments = flip
(foldl'
(\(MkEnvironment i e) arg -> MkEnvironment
(i + 1)
(HashMap.insert (unsafeRenderToText ("arg_" ++ show i)) arg e)
)
)
addLocalPositionalArguments
:: Member EnvironmentReader e => [String] -> Eff e a -> Eff e a
addLocalPositionalArguments extraPositional = localEnvironment appendVars
where
appendVars = addPositionalArguments (unsafeRenderToText <$> extraPositional)
fromStringPairs :: [(String, String)] -> Environment
fromStringPairs = MkEnvironment 0 . HashMap.fromList . fmap
(unsafeRenderToText *** unsafeRenderToText)
addBinding :: Member ExcB9 e => (Text, Text) -> Environment -> Eff e Environment
addBinding (k, vNew) env =
let h = fromEnvironment env
in case HashMap.lookup k h of
Just vOld | vOld /= vNew ->
throwSomeException (MkDuplicateKey k vOld vNew)
_ -> pure (MkEnvironment (nextPosition env) (HashMap.insert k vNew h))
addStringBinding
:: Member ExcB9 e => (String, String) -> Environment -> Eff e Environment
addStringBinding = addBinding . (unsafeRenderToText *** unsafeRenderToText)
addLocalStringBinding
:: (Member EnvironmentReader e, Member ExcB9 e)
=> (String, String)
-> Eff e a
-> Eff e a
addLocalStringBinding binding action = do
e <- askEnvironment
e' <- addStringBinding binding e
localEnvironment (const e') action
type EnvironmentReader = Reader Environment
runEnvironmentReader :: Environment -> Eff (EnvironmentReader ': e) a -> Eff e a
runEnvironmentReader = runReader
askEnvironment :: Member EnvironmentReader e => Eff e Environment
askEnvironment = ask
localEnvironment
:: Member EnvironmentReader e
=> (Environment -> Environment)
-> Eff e a
-> Eff e a
localEnvironment = local
lookupOrThrow :: ('[ExcB9, EnvironmentReader] <:: e) => Text -> Eff e Text
lookupOrThrow key = do
env <- askEnvironment
maybe (throwSomeException (MkKeyNotFound key env))
return
(HashMap.lookup key (fromEnvironment env))
lookupEither
:: Member EnvironmentReader e => Text -> Eff e (Either KeyNotFound Text)
lookupEither key = do
env <- askEnvironment
(return . maybe (Left (MkKeyNotFound key env)) Right)
(HashMap.lookup key (fromEnvironment env))
data DuplicateKey = MkDuplicateKey
{ duplicateKey :: Text
, duplicateKeyOldValue :: Text
, duplicateKeyNewValue :: Text
} deriving (Typeable, Show, Eq)
instance Exception DuplicateKey
data KeyNotFound =
MkKeyNotFound Text
Environment
deriving (Typeable, Eq)
instance Exception KeyNotFound
instance Show KeyNotFound where
showsPrec _ (MkKeyNotFound key env) =
let keys =
unlines (unsafeParseFromText <$> HashMap.keys (fromEnvironment env))
in showString "Invalid template parameter: \""
. showString (unsafeParseFromText key)
. showString "\".\nValid variables:\n"
. showString keys
hasKey :: Member EnvironmentReader e => Text -> Eff e Bool
hasKey k = isJust . HashMap.lookup k . fromEnvironment <$> askEnvironment