{-# language TemplateHaskell #-}
{-# options_ghc -Wno-unused-imports #-}
module IncludeEnv.TH (
includeEnv
, includeEnvLenient
, includeEnvMaybe
, includeEnvMap
) where
import Control.Monad (foldM)
import System.Environment (lookupEnv)
import qualified Data.Map.Strict as M (Map, lookup, insert, fromList)
import Language.Haskell.TH (runIO, runQ)
import Language.Haskell.TH.Syntax (Q, Exp(..), Dec(..), Pat(..), Name, mkName, Body(..), Lit(..), reportWarning)
import Language.Haskell.TH.Lib (valD)
import Instances.TH.Lift
includeEnv :: String
-> String
-> Q [Dec]
includeEnv :: String -> String -> Q [Dec]
includeEnv String
e String
varname = do
Maybe String
mstr <- IO (Maybe String) -> Q (Maybe String)
forall a. IO a -> Q a
runIO (IO (Maybe String) -> Q (Maybe String))
-> IO (Maybe String) -> Q (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
e
case Maybe String
mstr of
Just String
str -> String -> String -> Q [Dec]
decl String
varname String
str
Maybe String
Nothing -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"Cannot find variable", String
e, String
"in the environment."]
where
decl :: String -> String -> Q [Dec]
decl :: String -> String -> Q [Dec]
decl String
n String
x = [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
dq] where
dq :: Dec
dq = Pat -> Body -> [Dec] -> Dec
ValD Pat
qpat Body
qbody []
qpat :: Pat
qpat = Name -> Pat
VarP (String -> Name
mkName String
n)
qbody :: Body
qbody = Exp -> Body
NormalB (Lit -> Exp
LitE (String -> Lit
StringL String
x))
includeEnvLenient :: String
-> String
-> Q [Dec]
includeEnvLenient :: String -> String -> Q [Dec]
includeEnvLenient String
e String
varname = do
Maybe String
mstr <- IO (Maybe String) -> Q (Maybe String)
forall a. IO a -> Q a
runIO (IO (Maybe String) -> Q (Maybe String))
-> IO (Maybe String) -> Q (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
e
case Maybe String
mstr of
Just String
str -> String -> String -> Q [Dec]
decl String
varname String
str
Maybe String
Nothing -> do
String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"*** WARNING : Cannot find variable", String
e, String
"in the environment."]
String -> String -> Q [Dec]
decl String
varname String
""
where
decl :: String -> String -> Q [Dec]
decl :: String -> String -> Q [Dec]
decl String
n String
x = [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
dq] where
dq :: Dec
dq = Pat -> Body -> [Dec] -> Dec
ValD Pat
qpat Body
qbody []
qpat :: Pat
qpat = Name -> Pat
VarP (String -> Name
mkName String
n)
qbody :: Body
qbody = Exp -> Body
NormalB (Lit -> Exp
LitE (String -> Lit
StringL String
x))
includeEnvMaybe :: String
-> Q Exp
includeEnvMaybe :: String -> Q Exp
includeEnvMaybe String
e = do
Maybe String
mstr <- IO (Maybe String) -> Q (Maybe String)
forall a. IO a -> Q a
runIO (IO (Maybe String) -> Q (Maybe String))
-> IO (Maybe String) -> Q (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
e
[| mstr |]
includeEnvMap :: Foldable t =>
t String
-> Q Exp
includeEnvMap :: t String -> Q Exp
includeEnvMap t String
es = do
Map String String
mm <- (Map String String -> String -> Q (Map String String))
-> Map String String -> t String -> Q (Map String String)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map String String -> String -> Q (Map String String)
insf Map String String
forall a. Monoid a => a
mempty t String
es
[| mm |]
where
insf :: Map String String -> String -> Q (Map String String)
insf Map String String
acc String
k = do
Maybe String
mv <- IO (Maybe String) -> Q (Maybe String)
forall a. IO a -> Q a
runIO (IO (Maybe String) -> Q (Maybe String))
-> IO (Maybe String) -> Q (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
k
case Maybe String
mv of
Maybe String
Nothing -> Map String String -> Q (Map String String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map String String
acc
Just String
v -> Map String String -> Q (Map String String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map String String -> Q (Map String String))
-> Map String String -> Q (Map String String)
forall a b. (a -> b) -> a -> b
$ String -> String -> Map String String -> Map String String
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
k String
v Map String String
acc