------------------------------------------------------------------------
-- |
-- Module           : What4.Utils.Environemnt
-- Description      : Provides functions for finding an executable, and
--                    expanding a path with referenced to environment
--                    variables.
-- Copyright        : (c) Galois, Inc 2013-2020
-- License          : BSD3
-- Maintainer       : Joe Hendrix <jhendrix@galois.com>
-- Stability        : provisional
--
-- Provides functions for finding an executable, and expanding a path
-- with referenced to environment variables.
------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
module What4.Utils.Environment
  ( findExecutable
  , expandEnvironmentPath
  ) where

#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail( MonadFail )
#endif

import Control.Monad.IO.Class
import Data.Char
import Data.List (foldl')
import Data.Map (Map)
import qualified Data.Map as Map
import qualified System.Directory as Sys
import System.Environment
import System.FilePath

-- | Given a mapping of variables to values, this replaces
-- substrings of the form $VAR with the associated value
-- in a string.
expandVars :: MonadFail m => Map String String -> String -> m String
expandVars :: Map String String -> String -> m String
expandVars Map String String
m = ShowS -> String -> m String
forall (m :: Type -> Type).
MonadFail m =>
ShowS -> String -> m String
outsideVar ShowS
forall a. a -> a
id
  where -- Parse characters not part of a var.
        outsideVar :: MonadFail m => ShowS -> String -> m String
        outsideVar :: ShowS -> String -> m String
outsideVar ShowS
res String
s =
          case String
s of
            [] -> String -> m String
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ShowS
res [])
            Char
'$' : Char
'{' : String
r -> ShowS -> ShowS -> String -> m String
forall (m :: Type -> Type).
MonadFail m =>
ShowS -> ShowS -> String -> m String
matchBracketedVar ShowS
res ShowS
forall a. a -> a
id String
r
            Char
'$' : Char
c : String
r | Char -> Bool
isNumber Char
c -> ShowS -> ShowS -> String -> m String
forall (m :: Type -> Type) a.
MonadFail m =>
ShowS -> ([a] -> String) -> String -> m String
expandVar ShowS
res (Char -> ShowS
showChar Char
c) String
r
            Char
'$' : String
r -> ShowS -> ShowS -> String -> m String
forall (m :: Type -> Type).
MonadFail m =>
ShowS -> ShowS -> String -> m String
matchVarName ShowS
res ShowS
forall a. a -> a
id String
r
            Char
c   : String
r -> ShowS -> String -> m String
forall (m :: Type -> Type).
MonadFail m =>
ShowS -> String -> m String
outsideVar (ShowS
res ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
c) String
r

        -- Return true if this is a character.
        isVarChar :: Char -> Bool
        isVarChar :: Char -> Bool
isVarChar Char
'_' = Bool
True
        isVarChar Char
c = Char -> Bool
isAlphaNum Char
c

        matchVarName :: MonadFail m => ShowS -> ShowS -> String -> m String
        matchVarName :: ShowS -> ShowS -> String -> m String
matchVarName ShowS
res ShowS
rnm String
s =
          case String
s of
            [] -> ShowS -> ShowS -> String -> m String
forall (m :: Type -> Type) a.
MonadFail m =>
ShowS -> ([a] -> String) -> String -> m String
expandVar ShowS
res ShowS
rnm String
s
            Char
c:String
r | Char -> Bool
isVarChar Char
c -> ShowS -> ShowS -> String -> m String
forall (m :: Type -> Type).
MonadFail m =>
ShowS -> ShowS -> String -> m String
matchVarName ShowS
res (ShowS
rnm ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
c) String
r
                | Bool
otherwise -> ShowS -> ShowS -> String -> m String
forall (m :: Type -> Type) a.
MonadFail m =>
ShowS -> ([a] -> String) -> String -> m String
expandVar ShowS
res ShowS
rnm String
s

        matchBracketedVar :: ShowS -> ShowS -> String -> m String
matchBracketedVar ShowS
res ShowS
rnm String
s =
          case String
s of
            [] -> String -> m String
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Missing '}' to close variable name."
            Char
'}':String
r -> ShowS -> ShowS -> String -> m String
forall (m :: Type -> Type) a.
MonadFail m =>
ShowS -> ([a] -> String) -> String -> m String
expandVar ShowS
res ShowS
rnm String
r
            Char
c  :String
r -> ShowS -> ShowS -> String -> m String
matchBracketedVar ShowS
res (ShowS
rnm ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
c) String
r

        expandVar :: ShowS -> ([a] -> String) -> String -> m String
expandVar ShowS
res [a] -> String
rnm String
r = do
          let nm :: String
nm = [a] -> String
rnm []
          case String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
nm Map String String
m of
            Just String
v -> ShowS -> String -> m String
forall (m :: Type -> Type).
MonadFail m =>
ShowS -> String -> m String
outsideVar (ShowS
res ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
v) String
r
            Maybe String
Nothing -> String -> m String
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
"Could not find variable " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
nm
                              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in environment."

expandEnvironmentPath :: Map String String
                      -> String
                      -> IO String
expandEnvironmentPath :: Map String String -> String -> IO String
expandEnvironmentPath Map String String
base_map String
path = do
  -- Get program name.
  String
prog_name <- IO String
getExecutablePath
  let prog_path :: String
prog_path = ShowS
dropTrailingPathSeparator (ShowS
dropFileName String
prog_name)
  let init_map :: Map String String
init_map = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (String
"MSS_BINPATH", String
prog_path) ]
  -- Extend init_map with environment variables.
  [(String, String)]
env <- IO [(String, String)]
getEnvironment
  let expanded_map :: Map String String
expanded_map = (Map String String -> (String, String) -> Map String String)
-> Map String String -> [(String, String)] -> Map String String
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map String String
m (String
k,String
v) -> String -> String -> Map String String -> Map String String
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
k String
v Map String String
m) Map String String
init_map [(String, String)]
env
  -- Return expanded path.
  Map String String -> String -> IO String
forall (m :: Type -> Type).
MonadFail m =>
Map String String -> String -> m String
expandVars (Map String String -> Map String String -> Map String String
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map String String
base_map Map String String
expanded_map) String
path

-- | Find an executable from a string.
findExecutable :: (MonadIO m, MonadFail m)
               => FilePath
                  -- ^ Path to expand
               -> m FilePath
findExecutable :: String -> m String
findExecutable String
expanded_path = do
  -- Look for variable in expanded_path.
  Maybe String
mr <- IO (Maybe String) -> m (Maybe String)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> m (Maybe String))
-> IO (Maybe String) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
Sys.findExecutable String
expanded_path
  case Maybe String
mr of
    Maybe String
Nothing -> String -> m String
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
"Could not find: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
expanded_path
    Just String
r -> String -> m String
forall (m :: Type -> Type) a. Monad m => a -> m a
return String
r