diff --git a/src/VCSWrapper/Common/Process.hs b/src/VCSWrapper/Common/Process.hs --- a/src/VCSWrapper/Common/Process.hs +++ b/src/VCSWrapper/Common/Process.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : VCSWrapper.Common.Process @@ -26,13 +27,16 @@ import qualified Control.Exception as Exc import VCSWrapper.Common.Types import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T (null, unpack, pack) +import Control.Monad (unless) -- | Internal function to execute a VCS command. Throws an exception if the command fails. -vcsExecThrowingOnError :: String -- ^ VCS shell-command, e.g. git - -> String -- ^ VCS command, e.g. checkout - -> [String] -- ^ options - -> [(String, String)] -- ^ environment variables - -> Ctx String +vcsExecThrowingOnError :: FilePath -- ^ VCS shell-command, e.g. git + -> Text -- ^ VCS command, e.g. checkout + -> [Text] -- ^ options + -> [(Text, Text)] -- ^ environment variables + -> Ctx Text vcsExecThrowingOnError vcsName cmd opts menv = do o <- vcsExec vcsName cmd opts menv case o of @@ -40,20 +44,20 @@ Left exc -> Exc.throw exc -- | Internal function to execute a VCS command -vcsExec :: String -- ^ VCS shell-command, e.g. git - -> String -- ^ VCS command, e.g. checkout - -> [String] -- ^ options - -> [(String, String)] -- ^ environment variables - -> Ctx (Either VCSException String) +vcsExec :: FilePath -- ^ VCS shell-command, e.g. git + -> Text -- ^ VCS command, e.g. checkout + -> [Text] -- ^ options + -> [(Text, Text)] -- ^ environment variables + -> Ctx (Either VCSException Text) vcsExec vcsName cmd opts menv = exec cmd opts menv vcsName configPath -- | Internal function to execute a VCS command -exec :: String -- ^ VCS command, e.g. checkout - -> [String] -- ^ options - -> [(String, String)] -- ^ environment variables - -> String -- ^ VCS shell-command, e.g. git +exec :: Text -- ^ VCS command, e.g. checkout + -> [Text] -- ^ options + -> [(Text, Text)] -- ^ environment variables + -> FilePath -- ^ VCS shell-command, e.g. git -> (Config -> Maybe FilePath) -- ^ variable getter applied to content of Ctx - -> Ctx (Either VCSException String) + -> Ctx (Either VCSException Text) exec cmd opts menv fallBackExecutable getter = do cfg <- ask let args = cmd : opts @@ -69,14 +73,14 @@ environment. -} readProc :: Maybe FilePath --working directory or Nothing if not set - -> String --command - -> [String] --arguments - -> [(String, String)] --environment can be empty - -> String --input can be empty - -> IO (ExitCode, String, String) + -> FilePath --command + -> [Text] --arguments + -> [(Text, Text)] --environment can be empty + -> Text --input can be empty + -> IO (ExitCode, Text, Text) readProc mcwd command args menv input = do putStrLn $ "Executing process, mcwd: "++show mcwd++", command: "++command++ - ",args: "++show args++",menv: "++show menv++", input"++input + ",args: "++show args++",menv: "++show menv++", input"++T.unpack input (inh, outh, errh, pid) <- execProcWithPipes mcwd command args menv outMVar <- newEmptyMVar @@ -87,7 +91,7 @@ err <- hGetContents errh _ <- forkIO $ Exc.evaluate (length err) >> putMVar outMVar () - when (length input > 0) $ do hPutStr inh input; hFlush inh + unless (T.null input) $ do hPutStr inh (T.unpack input); hFlush inh hClose inh takeMVar outMVar @@ -96,20 +100,20 @@ hClose errh ex <- waitForProcess pid - return (ex, out, err) + return (ex, T.pack out, T.pack err) {- | Setting pipes as in 'System.Process.readProcessWithExitCode' in ' but having a configurable working directory and environment. -} -execProcWithPipes :: Maybe FilePath -> String -> [String] -> [(String, String)] +execProcWithPipes :: Maybe FilePath -> FilePath -> [Text] -> [(Text, Text)] -> IO (Handle, Handle, Handle, ProcessHandle) execProcWithPipes mcwd command args menv = do - (Just inh, Just outh, Just errh, pid) <- createProcess (proc command args) + (Just inh, Just outh, Just errh, pid) <- createProcess (proc command (map T.unpack args)) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe, cwd = mcwd, - env = Just menv } + env = Just (map (\(k,v) -> (T.unpack k, T.unpack v)) menv) } return (inh, outh, errh, pid) diff --git a/src/VCSWrapper/Common/TemporaryFiles.hs b/src/VCSWrapper/Common/TemporaryFiles.hs --- a/src/VCSWrapper/Common/TemporaryFiles.hs +++ b/src/VCSWrapper/Common/TemporaryFiles.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : VCSWrapper.Common.TemporaryFiles @@ -24,7 +25,7 @@ {- | Executes given function using a tempory file. -} -withTempFile :: String -- ^ Filename +withTempFile :: FilePath -- ^ Filename -> (FilePath -- 'FilePath' to temporary file -> Handle -- 'Handle' for temporary file -> IO a) -- ^ Fn to be called diff --git a/src/VCSWrapper/Common/Types.hs b/src/VCSWrapper/Common/Types.hs --- a/src/VCSWrapper/Common/Types.hs +++ b/src/VCSWrapper/Common/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : Common.Types @@ -11,7 +13,6 @@ -- | Defines all types and their associated accessorfunctions. -- ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} module VCSWrapper.Common.Types ( VCSType(..) ,IsLocked @@ -32,6 +33,8 @@ import Control.Monad.Reader import Data.Typeable (Typeable) import Control.Exception (Exception) +import Data.Text (Text) +import Control.Applicative (Applicative) -- | Available VCS types implemented in this package. data VCSType = SVN | GIT | Mercurial @@ -72,13 +75,13 @@ -- | Represents a log entry in the history managed by the VCS. data LogEntry = LogEntry { - mbBranch :: Maybe String -- ^ Maybe Branchname - , commitID :: String -- ^ Commit identifier - , author :: String -- ^ Author of this commit. - , email :: String -- ^ Email address of the author. - , date :: String -- ^ Date this log entry was created. - , subject :: String -- ^ Short commit message. - , body :: String -- ^ Long body of the commit message. + mbBranch :: Maybe Text -- ^ Maybe Branchname + , commitID :: Text -- ^ Commit identifier + , author :: Text -- ^ Author of this commit. + , email :: Text -- ^ Email address of the author. + , date :: Text -- ^ Date this log entry was created. + , subject :: Text -- ^ Short commit message. + , body :: Text -- ^ Long body of the commit message. } deriving (Show) -- | 'True', if this file is locked by the VCS. @@ -89,13 +92,13 @@ { configCwd :: Maybe FilePath -- ^ Path to the main directory of the repository. E.g. for Git: the directory of the repository containing the @.git@ config directory. , configPath :: Maybe FilePath -- ^ Path to the vcs executable. If 'Nothing', the PATH environment variable will be search for a matching executable. , configAuthor :: Maybe Author -- ^ Author to be used for different VCS actions. If 'Nothing', the default for the selected repository will be used. - , configEnvironment :: [(String, String)] -- ^ List of environment variables mappings passed to the underlying VCS executable. + , configEnvironment :: [(Text, Text)] -- ^ List of environment variables mappings passed to the underlying VCS executable. } deriving (Show, Read) -- | Author to be passed to VCS commands where applicable. data Author = Author - { authorName :: String -- ^ Name of the author. - , authorEmail :: Maybe String -- ^ Email address of the author. + { authorName :: Text -- ^ Name of the author. + , authorEmail :: Maybe Text -- ^ Email address of the author. } deriving (Show, Read) {- | Context for all VCS commands. @@ -108,13 +111,13 @@ > runVcs config $ initDB False -} newtype Ctx a = Ctx (ReaderT Config IO a) - deriving (Monad, MonadIO, MonadReader Config) + deriving (Functor, Applicative, Monad, MonadIO, MonadReader Config) -- | Creates a new 'Config' with a list of environment variables. makeConfigWithEnvironment :: Maybe FilePath -- ^ Path to the main directory of the repository. E.g. for Git: the directory of the repository containing the @.git@ config directory. -> Maybe FilePath -- ^ Path to the vcs executable. If 'Nothing', the PATH environment variable will be search for a matching executable. -> Maybe Author -- ^ Author to be used for different VCS actions. If 'Nothing', the default for the selected repository will be used. - -> [(String, String)] -- ^ List of environment variables mappings passed to the underlying VCS executable. + -> [(Text, Text)] -- ^ List of environment variables mappings passed to the underlying VCS executable. -> Config makeConfigWithEnvironment repoPath executablePath author environment = Config { configCwd = repoPath @@ -137,7 +140,7 @@ -- | This 'Exception'-type will be thrown if a VCS command fails unexpectedly. data VCSException -- | Exit code -> stdout -> errout -> 'configCwd' of the 'Config' -> List containing the executed command and its options - = VCSException Int String String String [String] + = VCSException Int Text Text FilePath [Text] deriving (Show, Typeable) instance Exception VCSException diff --git a/src/VCSWrapper/Git.hs b/src/VCSWrapper/Git.hs --- a/src/VCSWrapper/Git.hs +++ b/src/VCSWrapper/Git.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : VCSWrapper.Git @@ -48,7 +49,9 @@ import Data.Maybe import qualified Data.List -import Data.Text (strip, pack, unpack) +import Data.Text (Text) +import qualified Data.Text as T (strip, pack) +import Data.Monoid ((<>)) {- | Initialize a new git repository. Executes @git init@. -} @@ -63,27 +66,27 @@ -> Ctx () add paths = do let opts = "--" : paths - gitExecWithoutResult "add" opts [] + gitExecWithoutResult "add" (map T.pack opts) [] {- | Remove files from the index and the working directory. Executes @git rm@. -} rm :: [ FilePath ] -- ^ 'FilePath's to remove. -> Ctx () rm paths = do - let opts = "--" : paths + let opts = "--" : map T.pack paths gitExecWithoutResult "rm" opts [] {- | Commit the current index or the specified files to the repository. Executes @git commit@. -} commit :: [ FilePath ] -- ^ 'FilePath's to be commited instead of the current index. Leave empty to commit the index. - -> Maybe (String, String) -- ^ (Author name, email) - -> String -- ^ Commit message. Don't leave this empty. - -> [String] -- ^ Options to be passed to the git executable. + -> Maybe (Text, Text) -- ^ (Author name, email) + -> Text -- ^ Commit message. Don't leave this empty. + -> [Text] -- ^ Options to be passed to the git executable. -> Ctx () commit rsrcs mbAuthor logmsg extraopts = do case mbAuthor of Just (author, author_email) -> - commit' rsrcs logmsg extraopts ["--author", author ++ " <" ++ author_email ++ ">"] + commit' (map T.pack rsrcs) logmsg extraopts ["--author", author <> " <" <> author_email <> ">"] Nothing -> - commit' rsrcs logmsg extraopts [] + commit' (map T.pack rsrcs) logmsg extraopts [] where commit' files logmsg extraopts authopts = do let msgopts = [ "-m", logmsg ] @@ -91,8 +94,8 @@ gitExecWithoutResult "commit" opts [] {- | Checkout the index to some commit ID. Executes @git checkout@. -} -checkout :: Maybe String -- ^ Commit ID - -> Maybe String -- ^ Branchname. If specified, @git checkout -b \@ will be executed. +checkout :: Maybe Text -- ^ Commit ID + -> Maybe Text -- ^ Branchname. If specified, @git checkout -b \@ will be executed. -> Ctx () checkout rev branch = do let bopt = maybe [] (\b -> [ "-b", b ]) branch @@ -106,7 +109,7 @@ return $ parseStatus o {- | Get all commit messages. Executes @git log@. -} -simpleLog :: Maybe String -- ^ The branch from which to get the commit messages. (If 'Nothing', the current branch will be used). +simpleLog :: Maybe Text -- ^ The branch from which to get the commit messages. (If 'Nothing', the current branch will be used). -> Ctx [LogEntry] simpleLog mbBranch = do -- double dash on end prevent crash if branch and filename are equal @@ -118,13 +121,13 @@ {- | Get all local branches. Executes @git branch@. -} -localBranches :: Ctx (String, [String]) -- ^ (currently checked out branch, list of all other branches) +localBranches :: Ctx (Text, [Text]) -- ^ (currently checked out branch, list of all other branches) localBranches = do o <- gitExec "branch" [] [] return $ parseBranches o {- | Get all remotes. Executes @git remote@. -} -remote :: Ctx [String] +remote :: Ctx [Text] remote = do o <- gitExec "remote" [] [] return $ parseRemotes o @@ -136,7 +139,7 @@ {- | Pull changes from the remote as configured in the git configuration. If a merge conflict is detected, the error message is returned, otherwise 'Right ()' is returned. Executes @git pull@. -} -pull :: Ctx (Either String ()) +pull :: Ctx (Either Text ()) pull = do o <- gitExec' "pull" [] [] case o of @@ -145,11 +148,11 @@ else Exc.throw exc {- | Rev-parse a revision. Executes @git rev-parse@. -} -revparse :: String -- ^ Revision to pass to rev-parse. - -> Ctx (String) +revparse :: Text -- ^ Revision to pass to rev-parse. + -> Ctx (Text) revparse commit = do o <- gitExec "rev-parse" [commit] [] - return . unpack . strip $ pack o + return $ T.strip o diff --git a/src/VCSWrapper/Git/Parsers.hs b/src/VCSWrapper/Git/Parsers.hs --- a/src/VCSWrapper/Git/Parsers.hs +++ b/src/VCSWrapper/Git/Parsers.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : VCSWrapper.Git.Parsers @@ -26,50 +27,54 @@ import Text.ParserCombinators.Parsec import VCSWrapper.Common.Types +import Data.Text (Text) +import qualified Data.Text as T + (isPrefixOf, pack, lines, unpack, splitOn) +import Control.Applicative ((<$>)) -- | Parse the status of a Git repo. Expects command @git status --porcelain@. -parseStatus :: String -- ^ Output of @git status --porcelain@. +parseStatus :: Text -- ^ Output of @git status --porcelain@. -> [Status] -- ^ 'Status' for each file. parseStatus status = [ GITStatus filepath Modified | (_:x:_:filepath) <- lines, x == 'M'] -- M only displayed in second column ++ [ GITStatus filepath Untracked | (x:_:_:filepath) <- lines, x == '?'] ++ [ GITStatus filepath Added | (x:_:_:filepath) <- lines, x == 'A'] -- A only displayed in second column ++ [ GITStatus filepath Deleted | (x:y:_:filepath) <- lines, x == 'D' || y == 'D'] -- D flag depends on index state (both columns) where - lines = splitOn "\n" status + lines = map T.unpack $ T.splitOn "\n" status -- | Parse the output of @git branch@. -parseBranches :: String -> (String, [String]) -- ^ (currently checked out branch, list of all other branches) -parseBranches string = (head [branchname | ('*':_:branchname) <- lined], - [branchname | (' ':' ':branchname) <- lined]) +parseBranches :: Text -> (Text, [Text]) -- ^ (currently checked out branch, list of all other branches) +parseBranches string = (head [T.pack branchname | ('*':_:branchname) <- lined], + [T.pack branchname | (' ':' ':branchname) <- lined]) where - lined = lines string + lined = map T.unpack $ T.lines string -- | Parse @git remote@. -parseRemotes :: String -> [String] -parseRemotes = splitOn "\n" +parseRemotes :: Text -> [Text] +parseRemotes = T.splitOn "\n" -- | Parse output of @git pull@ and return if the repository is in conflict state. -parsePullMergeConflict :: String -> Bool -parsePullMergeConflict s = isPrefixOf "CONFLICT" s -- TODO improve this implementation, conflict after attemted automerge is not detected. +parsePullMergeConflict :: Text -> Bool +parsePullMergeConflict s = T.isPrefixOf "CONFLICT" s -- TODO improve this implementation, conflict after attemted automerge is not detected. -- | Parse output of @git log --pretty=tformat:commit:%H%n%an%n%ae%n%ai%n%s%n%b%x00@. -parseSimpleLog :: String -> [LogEntry] +parseSimpleLog :: Text -> [LogEntry] parseSimpleLog log = case parsed of Right entries -> entries Left _ -> [] - where parsed = parse logEntries "" log + where parsed = parse logEntries "" (T.unpack log) -- | Parse a single log entry. Expects @git log --pretty=tformat:commit:%H%n%an%n%ae%n%ai%n%s%n%b%x00@ logEntry :: Parser LogEntry logEntry = do string "commit:" - commitID <- wholeLine - author <- wholeLine - email <- wholeLine - date <- wholeLine - subject <- wholeLine - body <- bodyLines + commitID <- T.pack <$> wholeLine + author <- T.pack <$> wholeLine + email <- T.pack <$> wholeLine + date <- T.pack <$> wholeLine + subject <- T.pack <$> wholeLine + body <- T.pack <$> bodyLines char '\n' return $ LogEntry Nothing commitID author email date subject body diff --git a/src/VCSWrapper/Git/Process.hs b/src/VCSWrapper/Git/Process.hs --- a/src/VCSWrapper/Git/Process.hs +++ b/src/VCSWrapper/Git/Process.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : VCSWrapper.Git.Process @@ -25,13 +26,14 @@ import Control.Monad.Reader.Class (asks) import qualified Control.Exception as Exc +import Data.Text (Text) -- | Internal function to execute a git command -gitExec :: String -- ^ git command, e.g. checkout, commit - -> [String] -- ^ options - -> [(String, String)] -- ^ environment - -> Ctx String +gitExec :: Text -- ^ git command, e.g. checkout, commit + -> [Text] -- ^ options + -> [(Text, Text)] -- ^ environment + -> Ctx Text gitExec cmd opts env = do cfgEnv <- asks configEnvironment vcsExecThrowingOnError "git" cmd opts (cfgEnv ++ env) @@ -39,18 +41,18 @@ -- | Internal function to execute a git command. Doesn't throw an exception if the command failes, -- but returns an Either with exit information. -gitExec' :: String -- ^ git command, e.g. checkout, commit - -> [String] -- ^ options - -> [(String, String)] -- ^ environment - -> Ctx (Either VCSException String) +gitExec' :: Text -- ^ git command, e.g. checkout, commit + -> [Text] -- ^ options + -> [(Text, Text)] -- ^ environment + -> Ctx (Either VCSException Text) gitExec' cmd opts env = do cfgEnv <- asks configEnvironment vcsExec "git" cmd opts (cfgEnv ++ env) -gitExecWithoutResult :: String -- ^ git command to execute, e.g. checkout, commit - -> [String] -- ^ options - -> [(String, String)] -- ^ environment +gitExecWithoutResult :: Text -- ^ git command to execute, e.g. checkout, commit + -> [Text] -- ^ options + -> [(Text, Text)] -- ^ environment -> Ctx () gitExecWithoutResult cmd opts env = gitExec cmd opts env >> return () diff --git a/src/VCSWrapper/Mercurial.hs b/src/VCSWrapper/Mercurial.hs --- a/src/VCSWrapper/Mercurial.hs +++ b/src/VCSWrapper/Mercurial.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : VCSWrapper.Mercurial @@ -37,21 +38,23 @@ import System.IO import Control.Monad.Reader import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T (unpack, pack) {- | Add all new files, delete all missing files. Executes @hg addremove@. -} addremove :: [FilePath] -- ^ files to add -> Ctx () -addremove files = hgExecNoEnv "addremove" files +addremove files = hgExecNoEnv "addremove" (map T.pack files) {- | Update the repository's working directory to the specified changeset. If no changeset is specified, update to the tip of the current named branch. Executes @hg checkout@. -} -checkout :: Maybe String -- ^ optional changeset - -> [String] -- ^ options +checkout :: Maybe Text -- ^ optional changeset + -> [Text] -- ^ options -> Ctx () checkout mbChangeset options = hgExecNoEnv "checkout" opts where @@ -62,16 +65,16 @@ Commit the specified files or all outstanding changes. Executes @hg commit@. -} commit :: [FilePath] -- ^ files to commit. List may be empty - if not only specified files will be commited - -> String -- ^ message, can be empty - -> [String] -- ^ options + -> Text -- ^ message, can be empty + -> [Text] -- ^ options -> Ctx () commit filesToCommit logMsg options = hgExecNoEnv "commit" opts where msgOpt = [ "--message", logMsg ] - opts = msgOpt ++ options ++ filesToCommit + opts = msgOpt ++ options ++ (map T.pack filesToCommit) {- | Get all local branches. Executes @hg branches@. -} -localBranches :: Ctx (String, [String]) -- ^ (currently checked out branch, list of all other branches) +localBranches :: Ctx (Text, [Text]) -- ^ (currently checked out branch, list of all other branches) localBranches = do currentBranch <- hgExec "branch" [] [] o <- hgExec "branches" ["-q"] [] @@ -97,7 +100,7 @@ {- | Show revision history of entire repository or files. Executes @hg log@. -} -simpleLog :: Maybe String -- ^ Show the specified revision or range or branch +simpleLog :: Maybe Text -- ^ Show the specified revision or range or branch -> Ctx[LogEntry] simpleLog mbRev = do o <- hgExec "log" opts [] @@ -108,7 +111,7 @@ rev (Just revision) = ["-r",revision] opts = ["--style", "xml"] ++ (rev mbRev) parseLog out path handle = do - hPutStrLn handle out + hPutStrLn handle (T.unpack out) hClose handle -- closing handle so parseDocument can open one parseLogFile path @@ -124,7 +127,7 @@ Update the repository's working directory to the specified changeset. If no changeset is specified, update to the tip of the current named branch. -} -update :: Maybe String +update :: Maybe Text -> Ctx () update mbRev = hgExecNoEnv "update" opts where diff --git a/src/VCSWrapper/Mercurial/Parsers.hs b/src/VCSWrapper/Mercurial/Parsers.hs --- a/src/VCSWrapper/Mercurial/Parsers.hs +++ b/src/VCSWrapper/Mercurial/Parsers.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : VCSWrapper.Mercurial.Parsers @@ -21,20 +23,23 @@ import qualified VCSWrapper.Mercurial.Types as Common import Text.XML.HXT.Core import Data.List.Split (splitOn) +import Data.Text (Text) +import qualified Data.Text as T (pack, unpack, lines, splitOn) +import Control.Applicative ((<$>)) {- | - Parses given 'String' and returns a list of 'Status'. + Parses given 'Text' and returns a list of 'Status'. -} -parseStatusOut :: String -- ^ String which is required to have same format as output from @svn status@ +parseStatusOut :: Text -- ^ Text which is required to have same format as output from @svn status@ -> [Common.Status] parseStatusOut out = parseRows rows where rows = init' splitRows - splitRows = splitOn "\n" out :: [String] + splitRows = T.splitOn "\n" out :: [Text] -- | Parse the output of @hg branch -q@. -parseBranches :: String -> [String] -- ^ list of all branches -parseBranches string = lines string +parseBranches :: Text -> [Text] -- ^ list of all branches +parseBranches string = T.lines string {- | Attempts to parse given file and returns a list of 'Common.LogEntry'. @@ -56,7 +61,7 @@ init' ls = init ls -- parses given rows from @hg status@. Supports only first seven columns and filename so far -parseRows :: [String] -> [Common.Status] +parseRows :: [Text] -> [Common.Status] parseRows rows = map mapRow rows where mapRow = \row -> Common.GITStatus (getFileName row) (getModification row) @@ -65,8 +70,8 @@ -- ,modification=(getModification row) -- ,isLocked=(getLockStatus row) -- } - getFileName = (\row -> nFunc tail 2 row) :: String -> FilePath - getModification = (\row -> parseFirstCol $ row!!0) :: String -> Common.Modification + getFileName = (\row -> nFunc tail 2 $ T.unpack row) :: Text -> FilePath + getModification = (\row -> parseFirstCol $ T.unpack row!!0) :: Text -> Common.Modification @@ -97,16 +102,16 @@ data LogEntry = LogEntry { revision :: Int - ,node :: String - ,branch :: Maybe String + ,node :: Text + ,branch :: Maybe Text ,author :: Author , date :: Date , message :: Message } deriving (Show, Read) -type Author = (String, String) -type Date = String -type Message = String +type Author = (Text, Text) +type Date = Text +type Message = Text xpLog :: PU Log xpLog = xpWrap (\l -> Log l, \l -> (logEntries l)) @@ -120,8 +125,8 @@ xpLogEntry :: PU LogEntry xpLogEntry = xpWrap (\(rev,nod,bra,par,tag,aut,dat,msg) -> - LogEntry { revision = rev, node = nod, branch = bra, author = aut, date = dat, message = msg}, - \e -> (revision e, node e, branch e, Nothing, Nothing, author e, date e, message e)) + LogEntry { revision = rev, node = T.pack nod, branch = T.pack <$> bra, author = aut, date = T.pack dat, message = T.pack msg}, + \e -> (revision e, T.unpack $ node e, T.unpack <$> branch e, Nothing, Nothing, author e, T.unpack $ date e, T.unpack $ message e)) $ xpElem "logentry" $ xp8Tuple (xpAttr "revision" xpInt) (xpAttr "node" xpText0) @@ -136,8 +141,10 @@ xpAuthor :: PU Author -xpAuthor = xpWrap (id, id) +xpAuthor = xpWrap (packPair, unpackPair) $ xpElem "author" $ xpPair (xpAttr "email" xpText0) (xpText0) - + where + packPair (a, b) = (T.pack a, T.pack b) + unpackPair (a, b) = (T.unpack a, T.unpack b) diff --git a/src/VCSWrapper/Mercurial/Process.hs b/src/VCSWrapper/Mercurial/Process.hs --- a/src/VCSWrapper/Mercurial/Process.hs +++ b/src/VCSWrapper/Mercurial/Process.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : VCSWrapper.Mercurial.Process @@ -22,9 +23,10 @@ import VCSWrapper.Common.Process import VCSWrapper.Mercurial.Types import Control.Monad.Reader(ask) +import Data.Text (Text) -hgExecNoEnv :: String -- ^ cmd - -> [String] -- ^ opts +hgExecNoEnv :: Text -- ^ cmd + -> [Text] -- ^ opts -> Ctx() hgExecNoEnv cmd options = do config <- ask @@ -39,10 +41,10 @@ {- | Execute given hg command with given options and environment. -} -hgExec :: String -- ^ hg command, e.g. checkout - -> [String] -- ^ options - -> [(String, String)] -- ^ environment - -> Ctx String +hgExec :: Text -- ^ hg command, e.g. checkout + -> [Text] -- ^ options + -> [(Text, Text)] -- ^ environment + -> Ctx Text hgExec cmd opts = do let extOpts = opts++globalOpts vcsExecThrowingOnError "hg" cmd extOpts diff --git a/src/VCSWrapper/Svn.hs b/src/VCSWrapper/Svn.hs --- a/src/VCSWrapper/Svn.hs +++ b/src/VCSWrapper/Svn.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : Svn @@ -14,7 +16,6 @@ -- On unexpected behavior, these functions will throw a 'VCSException'. -- All functions will be executed with options @--non-interactive@ and @--no-auth-cache@ set. ----------------------------------------------------------------------------- -{-# LANGUAGE ScopedTypeVariables #-} module VCSWrapper.Svn ( -- svn commands add @@ -51,6 +52,9 @@ import Control.Monad (filterM) import System.Directory(doesFileExist, getDirectoryContents) import System.FilePath(combine, splitFileName) +import Data.Text (Text) +import qualified Data.Text as T (unpack, pack) +import Data.Monoid ((<>)) -- -- SVN COMMANDS @@ -61,25 +65,25 @@ They will be added in next commit.. Executes @svn add@. -} add :: [FilePath] -- ^ files to add - -> Maybe String -- ^ optional password - -> [String] -- ^ options + -> Maybe Text -- ^ optional password + -> [Text] -- ^ options -> Ctx () -add files = svnExec_ "add" files +add files = svnExec_ "add" (map T.pack files) {- | Checkout out a working copy from a repository. Executes @svn checkout@. -} -checkout :: [(String, Maybe String)] -- ^ list of (url, 'Maybe' revision). List must not be empty, however revision need not to be set - -> Maybe String -- ^ optional path - -> Maybe String -- ^ optional password - -> [String] -- ^ options +checkout :: [(Text, Maybe Text)] -- ^ list of (url, 'Maybe' revision). List must not be empty, however revision need not to be set + -> Maybe Text -- ^ optional path + -> Maybe Text -- ^ optional password + -> [Text] -- ^ options -> Ctx () checkout repos path = svnExec_ "checkout" opts where realPath = [fromMaybe "" path] urls = map (\(x,y) -> x - ++ (if (isNothing y) then "" else "@") - ++ fromMaybe "" y) + <> (if (isNothing y) then "" else "@") + <> fromMaybe "" y) repos opts = urls++realPath @@ -87,24 +91,24 @@ Send changes from your working copy to the repository. Executes @svn commit@. -} commit :: [FilePath] -- ^ files to commit. List may be empty - if not only specified files will be commited - -> String -- ^ message, can be empty - -> Maybe String -- ^ optional password - -> [String] -- ^ options + -> Text -- ^ message, can be empty + -> Maybe Text -- ^ optional password + -> [Text] -- ^ options -> Ctx () commit filesToCommit logMsg = svnExec_ "commit" opts where msgopts = [ "--message", logMsg ] - opts = msgopts ++ filesToCommit + opts = msgopts ++ (map T.pack filesToCommit) {- | Lock working copy paths or URLs in the repository, so that no other user can commit changes to them. Executes @svn lock@. -} lock :: [FilePath] -- ^ Files to lock, must not be empty - -> Maybe String -- ^ optional password - -> [String] -- ^ options + -> Maybe Text -- ^ optional password + -> [Text] -- ^ options -> Ctx () -lock files = svnExec_ "lock" files +lock files = svnExec_ "lock" (map T.pack files) @@ -113,19 +117,19 @@ Reverts working copy to given revision. Executes @svn merge -rHEAD:$revision .@. -} mergeHeadToRevision :: Integer -- ^ revision, e.g. 3 - -> Maybe String -- ^ optional password - -> [String] -- ^ options + -> Maybe Text -- ^ optional password + -> [Text] -- ^ options -> Ctx() -mergeHeadToRevision revision = svnExec_ "merge" ["-rHEAD:"++show revision,"."] +mergeHeadToRevision revision = svnExec_ "merge" ["-rHEAD:"<>(T.pack $ show revision),"."] {- | Remove @conflicted@ state on working copy files or directories. Executes @svn resolved@. -} resolved :: [FilePath] -- ^ files or directories to mark resolved - -> Maybe String -- ^ optional password - -> [String] -- ^ options + -> Maybe Text -- ^ optional password + -> [Text] -- ^ options -> Ctx() -resolved files = svnExec_ "resolved" files +resolved files = svnExec_ "resolved" (map T.pack files) {- | Get the log messages for the current working copy. Executes @svn log@. @@ -137,7 +141,7 @@ return logEntries where parseLog out path handle = do - hPutStrLn handle out + hPutStrLn handle (T.unpack out) hClose handle -- closing handle so parseDocument can open one parseLogFile path @@ -153,16 +157,16 @@ Unlock working copy paths or URLs. Executes @svn unlock@. -} unlock :: [FilePath] -- ^ Files to unlock, must not be empty - -> Maybe String -- ^ optional password - -> [String] -- ^ options + -> Maybe Text -- ^ optional password + -> [Text] -- ^ options -> Ctx () -unlock files = svnExec_ "unlock" files +unlock files = svnExec_ "unlock" (map T.pack files) {- | Bring changes from the repository into the working copy. Executes @svn update@. -} -update :: Maybe String -- ^ optional password - -> [String] -- ^ options +update :: Maybe Text -- ^ optional password + -> [Text] -- ^ options -> Ctx() update = svnExec_ "update" [] diff --git a/src/VCSWrapper/Svn/Parsers.hs b/src/VCSWrapper/Svn/Parsers.hs --- a/src/VCSWrapper/Svn/Parsers.hs +++ b/src/VCSWrapper/Svn/Parsers.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : VCSWrapper.Svn.Parsers @@ -21,6 +22,8 @@ import Text.XML.HXT.Core import Data.List.Split (splitOn) import qualified VCSWrapper.Common.Types as Common +import Data.Text (Text) +import qualified Data.Text as T (unpack, pack, splitOn) instance XmlPickler Log where xpickle = xpLog @@ -34,19 +37,19 @@ do logs <- runX (xunpickleDocument xpLog [ withRemoveWS yes, withValidate no] document) let log = head logs - let entries = map (\(LogEntry rev aut dat msg) -> Common.LogEntry Nothing (show rev) aut "" dat msg msg) + let entries = map (\(LogEntry rev aut dat msg) -> Common.LogEntry Nothing (T.pack $ show rev) aut "" dat msg msg) (logEntries log) return entries {- | - Parses given 'String' and returns a list of 'Common.Status'. + Parses given 'Text' and returns a list of 'Common.Status'. -} -parseStatusOut :: String -- ^ String which is required to have same format as output from @svn status@ +parseStatusOut :: Text -- ^ Text which is required to have same format as output from @svn status@ -> [Common.Status] parseStatusOut out = parseRows rows where rows = init' splitRows - splitRows = splitOn "\n" out :: [String] + splitRows = T.splitOn "\n" out :: [Text] -- @@ -68,9 +71,9 @@ , message :: Message } deriving (Show, Read) -type Author = String -type Date = String -type Message = String +type Author = Text +type Date = Text +type Message = Text xpLog :: PU Log xpLog = xpWrap (\l -> Log l, \l -> (logEntries l)) $ @@ -83,8 +86,8 @@ xpLogEntry :: PU LogEntry -xpLogEntry = xpWrap (\(rev,aut,dat,msg) -> LogEntry { revision = rev, author = aut, date = dat, message = msg}, - \e -> (revision e, author e, date e, message e)) $ +xpLogEntry = xpWrap (\(rev,aut,dat,msg) -> LogEntry { revision = rev, author = T.pack aut, date = T.pack dat, message = T.pack msg}, + \e -> (revision e, T.unpack $ author e, T.unpack $ date e, T.unpack $ message e)) $ xpElem "logentry" $ xp4Tuple (xpAttr "revision" xpInt) (xpElemWithText "author") @@ -100,7 +103,7 @@ init' ls = init ls -- parses given rows from @svn status@. Supports only first seven columns and filename so far -parseRows :: [String] -> [Common.Status] +parseRows :: [Text] -> [Common.Status] parseRows rows = map mapRow rows where mapRow = \row -> Common.SVNStatus (getFileName row) (getModification row) (getLockStatus row) @@ -109,9 +112,9 @@ -- ,modification=(getModification row) -- ,isLocked=(getLockStatus row) -- } - getFileName = (\row -> nFunc tail 8 row) :: String -> FilePath - getModification = (\row -> parseFirstCol $ row!!0) :: String -> Common.Modification - getLockStatus = (\row -> parseSixthCol $ row!!5) :: String -> Common.IsLocked + getFileName = (\row -> nFunc tail 8 $ T.unpack row) :: Text -> FilePath + getModification = (\row -> parseFirstCol $ T.unpack row!!0) :: Text -> Common.Modification + getLockStatus = (\row -> parseSixthCol $ T.unpack row!!5) :: Text -> Common.IsLocked nFunc :: (a -> a) -> Int -> a -> a nFunc _ 0 = id diff --git a/src/VCSWrapper/Svn/Process.hs b/src/VCSWrapper/Svn/Process.hs --- a/src/VCSWrapper/Svn/Process.hs +++ b/src/VCSWrapper/Svn/Process.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : Process @@ -28,11 +29,12 @@ import Control.Monad.Reader(ask) import qualified Control.Exception as Exc +import Data.Text (Text) -svnExec_ :: String -- ^ cmd - -> [String] -- ^ cmd specific opts - -> Maybe String -- ^ optional password - -> [String] -- ^ additional arguments +svnExec_ :: Text -- ^ cmd + -> [Text] -- ^ cmd specific opts + -> Maybe Text -- ^ optional password + -> [Text] -- ^ additional arguments -> Ctx() svnExec_ cmd cmdOpts pw opts = do config <- ask @@ -49,24 +51,24 @@ authopts (Just a) = ["--username", authorName a] {- | Execute given svn command with given options. -} -svnExecNoEnvirNoOpts :: String -- ^ svn command, e.g. checkout - -> Ctx String +svnExecNoEnvirNoOpts :: Text -- ^ svn command, e.g. checkout + -> Ctx Text svnExecNoEnvirNoOpts cmd = svnExecNoEnvir cmd [] {- | Execute given svn command with given options. -} -svnExecNoEnvir :: String -- ^ svn command, e.g. checkout - -> [String] -- ^ options - -> Ctx String +svnExecNoEnvir :: Text -- ^ svn command, e.g. checkout + -> [Text] -- ^ options + -> Ctx Text svnExecNoEnvir cmd opts = svnExec cmd opts [] {- | Execute given svn command with given options and environment. -} -svnExec :: String -- ^ svn command, e.g. checkout - -> [String] -- ^ options - -> [(String, String)] -- ^ environment - -> Ctx String +svnExec :: Text -- ^ svn command, e.g. checkout + -> [Text] -- ^ options + -> [(Text, Text)] -- ^ environment + -> Ctx Text svnExec cmd opts = do let extOpts = opts++globalOpts vcsExecThrowingOnError "svn" cmd extOpts @@ -75,10 +77,10 @@ -- | Internal function to execute a svn command. Doesn't throw an exception if the command failes, -- but returns an Either with exit information. -svnExec' :: String -- ^ svn command, e.g. checkout, commit - -> [String] -- ^ options - -> [(String, String)] -- ^ environment - -> Ctx (Either VCSException String) +svnExec' :: Text -- ^ svn command, e.g. checkout, commit + -> [Text] -- ^ options + -> [(Text, Text)] -- ^ environment + -> Ctx (Either VCSException Text) svnExec' cmd opts = do let extOpts = opts++globalOpts vcsExec "svn" cmd extOpts diff --git a/vcswrapper.cabal b/vcswrapper.cabal --- a/vcswrapper.cabal +++ b/vcswrapper.cabal @@ -1,5 +1,5 @@ name: vcswrapper -version: 0.0.4 +version: 0.1.0 cabal-version: >= 1.8 build-type: Simple license: GPL @@ -23,7 +23,7 @@ base >=4.0.0.0 && <4.8, directory >=1.1.0.0 && <1.3, hxt >=9.1.2 && <9.4, - mtl >=2.0.1.0 && <2.2, + mtl >=2.0.1.0 && <2.3, parsec >=3.1.1 && <3.2, process >=1.0.1.5 && <1.3, filepath >=1.2.0.0 && < 1.4, @@ -46,11 +46,12 @@ base >=4.0.0.0 && <4.8, directory >=1.1.0.0 && <1.3, hxt >=9.1.2 && <9.4, - mtl >=2.0.1.0 && <2.2, + mtl >=2.0.1.0 && <2.3, parsec >=3.1.1 && <3.2, process >=1.0.1.5 && <1.3, filepath >=1.2.0.0 && < 1.4, - split >=0.2.2 && <0.3 + split >=0.2.2 && <0.3, + text >=0.11.1.5 && <1.2 buildable: True hs-source-dirs: src other-modules: