diff options
| -rw-r--r-- | app/AddPath.hs | 36 | ||||
| -rw-r--r-- | app/ListPaths.hs | 13 | ||||
| -rw-r--r-- | app/Utils/Path.hs | 47 | ||||
| -rw-r--r-- | src/WindowsEnv/Environment.hs | 39 | ||||
| -rw-r--r-- | windows-env.cabal | 5 |
5 files changed, 78 insertions, 62 deletions
diff --git a/app/AddPath.hs b/app/AddPath.hs index 1152df6..209e28c 100644 --- a/app/AddPath.hs +++ b/app/AddPath.hs @@ -7,15 +7,16 @@ module Main (main) where -import Control.Monad (unless, void) +import Control.Monad (when, void) import Control.Monad.Trans.Except (catchE, runExceptT, throwE) -import Data.List ((\\), nub) +import Data.List (nub) import System.IO.Error (ioError, isDoesNotExistError) import Options.Applicative import qualified WindowsEnv +import Utils.Path import Utils.Prompt import Utils.PromptMessage @@ -71,30 +72,27 @@ addPath options = runExceptT doAddPath >>= either ioError return | otherwise = WindowsEnv.CurrentUser prepend = optPrepend options - mergePaths old new + appendPaths old new | prepend = new ++ old | otherwise = old ++ new emptyIfMissing e - | isDoesNotExistError e = defaultValue + | isDoesNotExistError e = return $ WindowsEnv.Value False "" | otherwise = throwE e - defaultValue = do - expandedPaths <- mapM WindowsEnv.expand pathsToAdd - if pathsToAdd == expandedPaths - then return $ WindowsEnv.Value False "" - else return $ WindowsEnv.Value True "" - doAddPath = do - oldValue <- WindowsEnv.query profile varName `catchE` emptyIfMissing - let expandable = WindowsEnv.valueExpandable oldValue - let joined = WindowsEnv.valueString oldValue - let split = WindowsEnv.pathSplit joined - let missing = pathsToAdd \\ split - unless (null missing) $ do - let merged = mergePaths split missing - let newValue = WindowsEnv.Value expandable (WindowsEnv.pathJoin merged) - promptAndEngrave oldValue newValue + newPaths <- pathExpandAll pathsToAdd + let newExpandable = pathAnyExpanded newPaths + srcValue <- WindowsEnv.query profile varName `catchE` emptyIfMissing + let srcExpandable = WindowsEnv.valueExpandable srcValue + let destExpandable = newExpandable || srcExpandable + srcPaths <- pathExpandValue srcValue + { WindowsEnv.valueExpandable = destExpandable } + let destPaths = appendPaths srcPaths $ filter (`notElem` srcPaths) newPaths + let destPathsJoined = WindowsEnv.pathJoin $ map pathOriginal destPaths + let destValue = WindowsEnv.Value destExpandable destPathsJoined + when (srcValue /= destValue) $ do + promptAndEngrave srcValue destValue promptAndEngrave oldValue newValue = do let promptAnd = if skipPrompt diff --git a/app/ListPaths.hs b/app/ListPaths.hs index 0c8483c..792c98b 100644 --- a/app/ListPaths.hs +++ b/app/ListPaths.hs @@ -11,6 +11,7 @@ import Control.Monad (filterM) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (runExceptT) import Data.Maybe (fromMaybe) +import System.Directory (doesDirectoryExist) import System.Environment (lookupEnv) import System.IO.Error (ioError) @@ -18,13 +19,15 @@ import Options.Applicative import qualified WindowsEnv +import Utils.Path + data WhichPaths = All | ExistingOnly | MissingOnly deriving (Eq, Show) -shouldListPath :: WhichPaths -> WindowsEnv.ExpandedPath -> IO Bool +shouldListPath :: WhichPaths -> ExpandedPath -> IO Bool shouldListPath All = return . const True -shouldListPath ExistingOnly = WindowsEnv.pathExists -shouldListPath MissingOnly = fmap not . WindowsEnv.pathExists +shouldListPath ExistingOnly = doesDirectoryExist . pathExpanded +shouldListPath MissingOnly = fmap not . doesDirectoryExist . pathExpanded data Source = Environment | Registry WindowsEnv.Profile deriving (Eq, Show) @@ -77,7 +80,7 @@ listPaths options = runExceptT doListPaths >>= either ioError return doListPaths = do varValue <- query - split <- WindowsEnv.pathSplitAndExpand varValue + split <- pathExpandValue varValue lift $ do wanted <- filterM (shouldListPath whichPaths) split - mapM_ (putStrLn . WindowsEnv.pathOriginal) wanted + mapM_ (putStrLn . pathOriginal) wanted diff --git a/app/Utils/Path.hs b/app/Utils/Path.hs new file mode 100644 index 0000000..01259e7 --- /dev/null +++ b/app/Utils/Path.hs @@ -0,0 +1,47 @@ +-- | +-- Copyright : (c) 2017 Egor Tensin <Egor.Tensin@gmail.com> +-- License : MIT +-- Maintainer : Egor.Tensin@gmail.com +-- Stability : experimental +-- Portability : Windows-only + +module Utils.Path + ( ExpandedPath(..) + , pathExpandValue + + , pathExpandAll + , pathAnyExpanded + ) where + +import Control.Monad.Trans.Except (ExceptT) + +import qualified WindowsEnv + +data ExpandedPath = ExpandedPath + { pathOriginal :: String + , pathExpanded :: String + } deriving (Eq, Show) + +pathExpandValue :: WindowsEnv.Value -> ExceptT IOError IO [ExpandedPath] +pathExpandValue value + | WindowsEnv.valueExpandable value = do + expanded <- expandOnce + zipWith ExpandedPath split <$> + if length expanded == length split + then return expanded + else expandEach + | otherwise = return $ zipWith ExpandedPath split split + where + joined = WindowsEnv.valueString value + split = WindowsEnv.pathSplit joined + expandOnce = WindowsEnv.pathSplit <$> WindowsEnv.expand joined + expandEach = WindowsEnv.expandAll split + +pathExpandAll :: [String] -> ExceptT IOError IO [ExpandedPath] +pathExpandAll paths = zipWith ExpandedPath paths <$> WindowsEnv.expandAll paths + +pathIsExpanded :: ExpandedPath -> Bool +pathIsExpanded path = pathOriginal path /= pathExpanded path + +pathAnyExpanded :: [ExpandedPath] -> Bool +pathAnyExpanded = any pathIsExpanded diff --git a/src/WindowsEnv/Environment.hs b/src/WindowsEnv/Environment.hs index 5bd5bf6..258a1ae 100644 --- a/src/WindowsEnv/Environment.hs +++ b/src/WindowsEnv/Environment.hs @@ -25,12 +25,7 @@ module WindowsEnv.Environment , pathSplit , expand - - , pathSplitAndExpand - , ExpandedPath(..) - , pathOriginal - , pathExpanded - , pathExists + , expandAll ) where import Control.Monad.Trans.Class (lift) @@ -39,7 +34,6 @@ import Data.List (intercalate) import Data.List.Split (splitOn) import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Storable (sizeOf) -import System.Directory (doesDirectoryExist) import System.IO.Error (catchIOError, isDoesNotExistError) import qualified System.Win32.Types as WinAPI @@ -125,32 +119,5 @@ expand value = ExceptT $ catchIOError (Right <$> doExpand) (return . Left) else WinAPI.peekTString bufferPtr doExpand = WinAPI.withTString value $ \valuePtr -> doExpandIn valuePtr WinAPI.nullPtr 0 -data ExpandedPath = UnexpandedPath String - | ExpandedPath String String - deriving (Eq, Show) - -pathOriginal :: ExpandedPath -> String -pathOriginal (UnexpandedPath path) = path -pathOriginal (ExpandedPath original _) = original - -pathExpanded :: ExpandedPath -> String -pathExpanded (UnexpandedPath path) = path -pathExpanded (ExpandedPath _ expanded) = expanded - -pathExists :: ExpandedPath -> IO Bool -pathExists = doesDirectoryExist . pathExpanded - -pathSplitAndExpand :: Value -> ExceptT IOError IO [ExpandedPath] -pathSplitAndExpand value - | valueExpandable value = do - expanded <- expandOnce - zipWith ExpandedPath split <$> - if length expanded == length split - then return expanded - else expandEach - | otherwise = return $ map UnexpandedPath $ pathSplit joined - where - joined = valueString value - split = pathSplit joined - expandOnce = pathSplit <$> expand joined - expandEach = mapM expand split +expandAll :: [String] -> ExceptT IOError IO [String] +expandAll = mapM expand diff --git a/windows-env.cabal b/windows-env.cabal index 9850c2c..d25e427 100644 --- a/windows-env.cabal +++ b/windows-env.cabal @@ -37,7 +37,7 @@ library executable addpath hs-source-dirs: app main-is: AddPath.hs - other-modules: Utils.Prompt, Utils.PromptMessage + other-modules: Utils.Path, Utils.Prompt, Utils.PromptMessage ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: base , optparse-applicative @@ -48,9 +48,10 @@ executable addpath executable paths hs-source-dirs: app main-is: ListPaths.hs - other-modules: Utils.Prompt, Utils.PromptMessage + other-modules: Utils.Path, Utils.Prompt, Utils.PromptMessage ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: base + , directory , optparse-applicative , transformers , windows-env |