Work in Progess: Synchronize Haskell version to new changes #5

.gitignore

@@ -4,6 +4,7 @@
 # Directories
 src/.bin
 .cache/
+**/.hpc
 **/__pycache__
 .pytest_cache
 **/.stack-work

.travis.yml

@@ -22,15 +22,7 @@ matrix:
     # You could also do things like change flags or
     # use --stack-yaml to point to a different file.
     - env: ARGS=""
-      python: "2.7"
-    - env: ARGS="--resolver lts-2"
-      python: "2.7"
-    - env: ARGS="--resolver lts-3"
-      python: "2.7"
-    - env: ARGS="--resolver lts"
-      python: "2.7"
-    - env: ARGS="--resolver nightly"
-      python: "2.7"
+      ghc: "8.2.2"
 
 # # GHC depends on GMP. You can add other dependencies here as well.
 addons:
@@ -40,6 +32,9 @@ addons:
 
 # Download and unpack the stack executable for haskell, else pip deps.
 install:
+  - sudo add-apt-repository ppa:duggan/bats --yes
+  - sudo apt-get update -qq
+  - sudo apt-get install -qq bats
   - if [ "$ARGS" = "python" ]; then
       pip install tox;
     else
@@ -55,7 +50,10 @@ script:
   - if [ "$ARGS" = "python" ]; then
       tox;
     else
-      stack $ARGS --no-terminal --install-ghc test --haddock;
+      stack $ARGS --no-terminal --install-ghc test --haddock --coverage;
+      export PATH=/home/travis/build/madnight/zsh-git-prompt/src/.bin:$PATH;
+      stack install;
+      bats src/test/test.sh;
     fi
 
 # Caching so the next build will be fast too.

src/app/Main.hs

@@ -1,37 +1,111 @@
-import System.Process (readProcessWithExitCode)
-import System.Exit (ExitCode(ExitSuccess))
-import System.IO.Unsafe (unsafeInterleaveIO)
+import Utils (safeRun, stringsFromStatus, readHandler,
+  fromBool, strip, Hash(MkHash))
 
-import Utils (stringsFromStatus, Hash(MkHash))
+import Control.Monad (when)
+import Data.Git.Ref()
+import Data.Git.Storage (findRepoMaybe)
+import Data.List (isInfixOf, isPrefixOf)
+import Data.List.Split (splitOn)
 import Data.Maybe (fromMaybe)
+import Filesystem.Path.CurrentOS (encodeString)
+import System.Directory (doesFileExist)
+import System.Environment (lookupEnv)
+import System.FilePath ((</>))
+import System.IO.Unsafe (unsafeInterleaveIO)
+import System.Posix.IO (stdInput)
+import System.Posix.Terminal (queryTerminal)
+import System.Exit (exitSuccess)
 
-{- Git commands -}
+import qualified Control.Exception.Base as E
 
-successOrNothing :: (ExitCode, a, b) -> Maybe a
-successOrNothing (exitCode, output, _) =
-	if exitCode == ExitSuccess then Just output else Nothing
+gitrevparse :: IO (Maybe Hash)
+gitrevparse = do
+    mresult <- safeRun "git" ["rev-parse", "--short", "HEAD"]
+    return $ MkHash . init <$> mresult
 
-safeRun :: String -> [String] -> IO (Maybe String)
-safeRun command arguments =
-	do -- IO
-		output <- readProcessWithExitCode command arguments ""
-		return (successOrNothing output)
+getStashCount :: FilePath -> IO Int
+getStashCount repo =
+    countLinesInFile $ repo </> "logs" </> "refs" </> "stash"
+    where
+        countLinesInFile :: String -> IO Int
+        countLinesInFile f = length . lines <$> E.catch (readFile f) readHandler
 
-gitrevparse :: IO (Maybe Hash)
-gitrevparse = do -- IO
-		mresult <- safeRun "git" ["rev-parse", "--short", "HEAD"]
-		let rev = do -- Maybe
-			result <- mresult
-			return (MkHash (init result))
-		return rev
+-- | Determine the rebase status of this repostitory and return it.
+-- | Args: git root
+-- | Returns:
+-- |    - "0": No active rebase
+-- |    - "1/4": Rebase in progress, commit 1 of 4
+rebaseProgess :: FilePath -> IO String
+rebaseProgess repo = do
+    let readRebase = readFile . ((repo </> "rebase-apply") </>)
+    next <- E.catch (readRebase "next") readHandler
+    last' <- E.catch (readRebase "last") readHandler
+    if length (last' ++ next) < 1
+        then pure "0"
+        else pure $ strip next ++ "/" ++ strip last'
+
+isMergeInProgess :: FilePath -> IO Bool
+isMergeInProgess = doesFileExist . (</> "MERGE_HEAD")
+
+parseBranch :: String -> FilePath -> IO (String, String, Int)
+parseBranch status repo
+    | "..." `isInfixOf` status = do
+            let getBranch = splitOn "..." . head . tail $ words status
+            let branch = head getBranch
+            let upstream = last getBranch
+            pure (branch, upstream, 0)
+    | "no branch" `isInfixOf` status = do
+            let readHead = readFile $ repo </> "HEAD"
+            head' <- E.catch readHead readHandler
+            let hashPrefixEnv = "ZSH_THEME_GIT_PROMPT_HASH_PREFIX"
+            sym_prehash <-  fromMaybe ":" <$> lookupEnv hashPrefixEnv
+            pure (sym_prehash ++ take 7 head', "..", 0)
+    | "Initial Commit" `isPrefixOf` status
+        || isPrefixOf "No commits yet" status = do
+            let branch = last $ words status
+            pure (branch, "..", 1)
+    | otherwise = pure (head . tail $ words status, "..", 1)
+
+parse :: String -> IO ()
+parse status = do
+    maybeRepo <- (fmap . fmap) encodeString findRepoMaybe
+    let repo = fromMaybe mempty maybeRepo
+    when (null repo) $ exitSuccess
+    stashCount <- getStashCount repo
+    merge <- isMergeInProgess  repo
+    rebase <- rebaseProgess repo
+    mhash <- unsafeInterleaveIO gitrevparse
+    (_, upstream, local) <- parseBranch status repo
+    let parseStatus =  maybe mempty unwords . stringsFromStatus mhash
+    let echo = putStr . (' ' :)
 
-{- main -}
+    -- 0. The branch.
+    -- 1. If branch is tracked upstream, number of commits behind.
+    -- 2. If branch is tracked upstream, number of commits ahead.
+    -- 3. The number of staged files.
+    -- 4. The number of conflict files (i.e. unmerged).
+    -- 5. The number of changed files (i.e. tracked and edited)
+    -- 6. The number of untracked files (does not include ignored).
+    putStr $ parseStatus status -- e.g. master 0 0 0 0 0 0
+    -- 7. The number of stashes on the current repository.
+    echo $ show stashCount
+    -- 8. 1 iff we are on a branch and that branch has no upstream tracking set.
+    echo $ show local
+    -- 9. The name of the upstream remote/branch set to track, e.g. origin/master
+    echo upstream
+    -- 10. 1 iff engaged in a merge operation. 0 otherwise.
+    echo . show $ fromBool merge
+    -- 11. rebase indicator, format m/n, m is the current commit we are checked
+    --     out on to resolve /  n is the total no of commits to, 0 otherwise.
+    echo rebase
 
 main :: IO ()
-main = do -- IO
-	status <- getContents
-	mhash <- unsafeInterleaveIO gitrevparse -- defer the execution until we know we need the hash
-	let result = do -- Maybe
-		strings <- stringsFromStatus mhash status
-		return (unwords strings)
-	putStr (fromMaybe "" result)
+main = do
+    isTTY <- queryTerminal stdInput
+    if isTTY
+        then do -- run status command
+            status <- safeRun "git" ["status", "--porcelain", "--branch"]
+            case status of
+                Nothing -> exitSuccess
+                Just s -> parse s
+        else getContents >>= parse -- get status from stdin

src/default.nix

@@ -0,0 +1,40 @@
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
+
+let
+
+  inherit (nixpkgs) pkgs;
+
+  f = { mkDerivation, base, directory, filepath, git, HUnit, parsec
+      , process, QuickCheck, split, stdenv, system-filepath, unix
+      }:
+      mkDerivation {
+        pname = "git-prompt";
+        version = "0.1.0.0";
+        src = ./.;
+        isLibrary = true;
+        isExecutable = true;
+        libraryHaskellDepends = [
+          base directory filepath git parsec process QuickCheck split
+          system-filepath unix
+        ];
+        executableHaskellDepends = [
+          base directory filepath git parsec process QuickCheck split
+          system-filepath unix
+        ];
+        testHaskellDepends = [ base HUnit parsec process QuickCheck ];
+        homepage = "http://github.com/olivierverdier/zsh-git-prompt#readme";
+        description = "Informative git prompt for zsh";
+        license = stdenv.lib.licenses.mit;
+      };
+
+  haskellPackages = if compiler == "default"
+                       then pkgs.haskellPackages
+                       else pkgs.haskell.packages.${compiler};
+
+  variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
+
+  drv = variant (haskellPackages.callPackage f {});
+
+in
+
+  if pkgs.lib.inNixShell then drv.env else drv

src/git-prompt.cabal

@@ -15,35 +15,34 @@ cabal-version:       >=1.10
 library
   hs-source-dirs:      src
   exposed-modules:     Utils, BranchParse, StatusParse
-  build-depends:       base, parsec >=3.1, process>=1.1.0.2, QuickCheck
+  build-depends:       base, parsec >=3.1, process>=1.1.0.2, QuickCheck, git, unix, system-filepath, directory, filepath, split
   default-language:    Haskell2010
-  ghc-options: -Wall -O2 -fno-warn-tabs -fno-warn-unused-do-bind
-  cc-options: -O3
+  ghc-options: -Wall -O2 -funfolding-use-threshold=16
+  cc-options: -Ofast
 
 executable gitstatus
   hs-source-dirs:      app
   main-is:             Main.hs
-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
-  build-depends:       base, git-prompt, parsec >=3.1, process>=1.1.0.2, QuickCheck
+  build-depends:       base, git-prompt, parsec >=3.1, process>=1.1.0.2, QuickCheck, git, unix, system-filepath, directory, filepath, split
   default-language:    Haskell2010
-  ghc-options: -Wall -O2 -fno-warn-tabs -fno-warn-unused-do-bind
-  cc-options: -O3
+  ghc-options: -Wall -O2 -funfolding-use-threshold=16
+  cc-options: -Ofast
 
 
 test-suite tests-branch
   type:              exitcode-stdio-1.0
   hs-source-dirs:    test
   main-is:           TestBranchParse.hs
   build-depends:     base, git-prompt, parsec >=3.1, process>=1.1.0.2, QuickCheck, HUnit >= 1.2
-  ghc-options: -Wall -O2 -fno-warn-tabs -fno-warn-unused-do-bind
+  ghc-options: -Wall -O2 -funfolding-use-threshold=16
   default-language:  Haskell2010
 
 test-suite tests-functional
   type:              exitcode-stdio-1.0
   hs-source-dirs:    test
   main-is:           TestFunctional.hs
   build-depends:     base, git-prompt, parsec >=3.1, process>=1.1.0.2, QuickCheck, HUnit >= 1.2
-  ghc-options: -Wall -O2 -fno-warn-tabs -fno-warn-unused-do-bind
+  ghc-options: -Wall -O2 -funfolding-use-threshold=16
   default-language:  Haskell2010
 
 source-repository head