From 6a23c04186835a394298d52dfe27fd8a37e4d734 Mon Sep 17 00:00:00 2001 From: Imam Tashdid ul Alam Date: Thu, 7 Sep 2017 22:41:28 +1000 Subject: [PATCH] initial implementation --- .gitignore | 1 + Makefile | 10 +++ haskell-powerline.hs | 186 +++++++++++++++++++++++++++++++++++++++++++ setup.sh | 9 +++ 4 files changed, 206 insertions(+) create mode 100644 Makefile create mode 100644 haskell-powerline.hs create mode 100644 setup.sh diff --git a/.gitignore b/.gitignore index 450f32e..1196fca 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +haskell-powerline dist dist-* cabal-dev diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..170ccae --- /dev/null +++ b/Makefile @@ -0,0 +1,10 @@ +all: build clean + +build: + ghc --make -O2 -o haskell-powerline haskell-powerline.hs + +build-static: + ghc -O2 --make -static -optc-static -optl-static -optl-pthread -o haskell-powerline haskell-powerline.hs + +clean: + rm -rf *.hi *.o diff --git a/haskell-powerline.hs b/haskell-powerline.hs new file mode 100644 index 0000000..add8739 --- /dev/null +++ b/haskell-powerline.hs @@ -0,0 +1,186 @@ +module Main where + +import System.Environment (getArgs, lookupEnv) +import System.Directory (getCurrentDirectory) +import Data.List (isPrefixOf, nub, sort, groupBy, intersperse) +import System.Process (readCreateProcessWithExitCode, StdStream(..), std_out, std_err, proc) +import System.Exit (ExitCode(..)) + +import Text.Parsec (ParseError, parse, manyTill, try, string, anyChar, eof, (<|>)) +import Text.Parsec.String (Parser) +import Text.Parsec.Char (char) + +-- powerline symbols +branch = "\xe0a0" +lock = "\xe0a2" +separator = "\xe0b0" +outline = "\xe0b1" + +detached = "\x2693" +ahead = "\x2b06" +behind = "\x2b07" +staged = "\x2714" +not_staged = "\x270e" +untracked = "\x2753" +conflicted = "\x273c" + +ellipsis = "\x2026" + +-- colors +data Color = Color{fg :: Int, bg :: Int} + +username = Color{fg = 250, bg = 240} +hostname = Color{fg = 250, bg = 238} + +home = Color{fg = 15, bg = 31} +path = Color{fg = 250, bg = 237} + +outline_fg = 244 +cwd_color = Color{fg = 254, bg = 237} + +ssh = Color{ fg = 254, bg = 166 } + +repo_clean = Color{fg = 0, bg = 148} +repo_dirty = Color{fg = 15, bg = 161} + +cmd_passed = Color{fg = 15, bg = 236} +cmd_failed = Color{fg = 15, bg = 160} + +git_ahead = Color{fg = 250, bg = 240} +git_behind = Color{fg = 250, bg = 240} +git_staged = Color{fg = 15, bg = 22} + +git_not_staged = Color{fg = 15, bg = 130} +git_conflicted = Color{fg = 15, bg = 9} + +git_untracked = Color{fg = 15, bg = 52} + +virtual_env = Color{fg = 0, bg = 35} + +template x = "\\[\\e" ++ x ++ "\\]" + +reset = template "[0m" + +fgcolor code = template $ "[38;5;" ++ show code ++ "m" +bgcolor code = template $ "[48;5;" ++ show code ++ "m" + +-- segment rendering +data Segment = Segment{content :: String, color :: Color} + +render (Segment{content = content, color = color}) = concat [fgcolor (fg color), + bgcolor (bg color), + content] + +append x y | content x == "" = y + | content y == "" = x + | otherwise = Segment{content = joined, color = color y} + where joined = render x ++ middle ++ render y + cx = color x + cy = color y + middle = if bg cx == bg cy + then fgcolor outline_fg ++ outline + else concat [fgcolor (bg cx), + bgcolor (bg cy), + separator] + +segment content color = Segment { content = " " ++ content ++ " ", color = color } + +-- powerline segments +empty_segment = Segment{content = "", color = Color{ fg = 0, bg = 15 }} + +username_segment = segment "\\u" username +hostname_segment = segment "\\h" hostname + +status_segment status = if status == 0 + then segment sym cmd_passed + else segment sym cmd_failed + where sym = "\\$" + +ssh_segment Nothing = empty_segment +ssh_segment (Just _) = segment lock ssh + +cwd_segments _ Nothing = [] +cwd_segments cwd (Just home_folder) = home_seg : rest_segs + where in_home = isPrefixOf home_folder cwd + home_seg = if in_home then segment "~" home else empty_segment + rest = if in_home then drop (length home_folder) cwd else cwd + words s = case dropWhile (== '/') s of + "" -> [] + s' -> w : words s'' where (w, s'') = break (== '/') s' + pieces = words rest + rest_segs = if pieces == [] + then [] + else let last_seg = segment (last pieces) cwd_color + init_segs = [segment piece path | piece <- init pieces] + omit_seg = segment ellipsis path + trimmed segs = drop (length segs - 2) segs + trim segs = if length segs < 3 then segs else omit_seg : trimmed segs + in trim init_segs ++ [last_seg] + +data GitStatus = Untracked | Staged | NotStaged | Conflicted + deriving (Eq, Ord) + +instance Show GitStatus where + show Untracked = untracked + show Conflicted = conflicted + show NotStaged = not_staged + show Staged = staged + + +git_segment (ExitSuccess, stdout, stderr) = result + where result = segment (branch ++ " " ++ info) color + dirty = length status_groups > 0 + color = if dirty then repo_dirty else repo_clean + info = concat (intersperse " " (status_groups ++ [branch_name])) + in_lines = lines stdout + pairs ls = let len = length ls + in (if len == 1 then "" else (show len)) ++ show (head ls) + status_groups = map pairs $ groupBy (==) status_info + status_info = sort $ map (code . take 2) (drop 1 in_lines) + branch_line = head in_lines + branch_name = case (parse branch_info "name" branch_line) of + Left _ -> "unknown" + Right local -> local + branch_info = do _ <- char '#' + _ <- char '#' + _ <- char ' ' + local <- try (manyTill anyChar (try (string "..."))) <|> manyTill anyChar eof + return local + code "??" = Untracked + code "DD" = Conflicted + code "AU" = Conflicted + code "UD" = Conflicted + code "UA" = Conflicted + code "DU" = Conflicted + code "AA" = Conflicted + code "UU" = Conflicted + code (' ':_) = NotStaged + code (_:" ") = Staged + code x = error $ "did not understand code " ++ x + +git_segment (ExitFailure _, _, _) = empty_segment + + +render_all xs = render one_piece ++ reset ++ fgcolor last_bg ++ separator + where one_piece = foldl append empty_segment xs + last_bg = bg (color one_piece) + +-- external interaction +processArgs = do [arg] <- getArgs + let status = read arg :: Int + return status + +git_status = result + where process = proc "git" ["status", "--porcelain", "-b"] + result = process{std_out = CreatePipe, std_err = CreatePipe} + +main = do status <- processArgs + cwd <- getCurrentDirectory + home <- lookupEnv "HOME" + git_result <- readCreateProcessWithExitCode git_status "" + ssh_client <- lookupEnv "SSH_CLIENT" + putStr $ render_all ([username_segment, + ssh_segment ssh_client, + hostname_segment] ++ cwd_segments cwd home ++ + [git_segment git_result, status_segment status]) + putStr $ reset ++ " " diff --git a/setup.sh b/setup.sh new file mode 100644 index 0000000..2c2221e --- /dev/null +++ b/setup.sh @@ -0,0 +1,9 @@ +export LANG=en_AU.UTF-8 + +DIR=$(dirname $(readlink -f ${BASH_SOURCE[0]})) + +function _update_ps1() { + PS1="$($DIR/haskell-powerline $? 2> /dev/null)" +} + +PROMPT_COMMAND="_update_ps1; $PROMPT_COMMAND"