messed up color somehow

.gitignore

@@ -1,4 +1,5 @@
 haskell-powerline
+powerline
 dist
 dist-*
 cabal-dev

Colors.hs

@@ -0,0 +1,33 @@
+module Colors where
+
+data Color = Color{fg :: Int, bg :: Int}
+
+empty = Color{fg = 0, bg = 15}
+
+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 = Color{fg = 244, bg = 0}
+cwd = 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}

Main.hs

@@ -0,0 +1,40 @@
+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 qualified Segments
+
+-- 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 (fg outline) ++ outline
+--                                             else concat [fgcolor (bg cx),
+--                                                          bgcolor (bg cy),
+--                                                          separator]
+--
+
+-- 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 $ Segments.render [Segments.username, Segments.ssh ssh_client,
+                                    Segments.hostname, Segments.cwd cwd home,
+                                    Segments.git git_result, Segments.status status]

Makefile

@@ -1,10 +1,10 @@
 all: build clean
 
 build:
-	ghc --make -O2 -o haskell-powerline haskell-powerline.hs
+	ghc --make -O2 -o powerline Main.hs
 
 build-static:
-	ghc -O2 --make -static -optc-static -optl-static -optl-pthread -o haskell-powerline haskell-powerline.hs
+	ghc -O2 --make -static -optc-static -optl-static -optl-pthread -o powerline Main.hs
 
 clean:
 	rm -rf *.hi *.o

Segments.hs

@@ -0,0 +1,107 @@
+module Segments where
+
+import Data.Monoid ((<>))
+import Data.List (isPrefixOf, intersperse, sort, groupBy)
+
+import System.Exit (ExitCode(..))
+
+import qualified Symbols
+import qualified Colors
+import Colors (fg, bg)
+
+import Text.Parsec (ParseError, parse, manyTill, try, string, anyChar, eof, (<|>))
+import Text.Parsec.String (Parser)
+import Text.Parsec.Char (char)
+
+data Segment = Segment{content :: String, left :: Colors.Color, right :: Colors.Color}
+
+template x = "\\[\\e" ++ x ++ "\\]"
+
+reset = template "[0m"
+
+fgcolor code = template $ "[38;5;" ++ show code ++ "m"
+bgcolor code = template $ "[48;5;" ++ show code ++ "m"
+
+
+instance Show Segment where
+    show (Segment{content = content, left = left, right = right})
+        = concat [fgcolor (fg left), bgcolor (bg left), content, fgcolor (fg right), bgcolor (bg right)]
+
+instance Monoid Segment where
+    mempty = Segment{content = "", left = Colors.empty, right = Colors.empty}
+    mappend x y = Segment{content = whole, left = left x, right = right y}
+        where whole = concat [content x,
+                              fgcolor (fg (right x)), bgcolor (bg (right x)),
+                              fgcolor (fg (left x)), bgcolor (bg (left x)),
+                              content y]
+
+segment content color = Segment { content = " " ++ content ++ " ", left = color, right = color}
+
+username = segment "\\u" Colors.username
+hostname = segment "\\h" Colors.hostname
+
+status code = if code == 0
+                  then segment sym Colors.cmd_passed
+                  else segment sym Colors.cmd_failed
+              where sym = "\\$"
+
+ssh Nothing = mempty
+ssh (Just _) = segment Symbols.lock Colors.ssh
+
+cwd current_folder home = foldl (<>) mempty (segments home)
+    where segments Nothing = rest_segs (words current_folder)
+          segments (Just home_folder) = home_seg : (rest_segs (words rest))
+              where
+              rest = if in_home then drop (length home_folder) current_folder else current_folder
+              in_home = isPrefixOf home_folder current_folder
+              home_seg = if in_home then segment "~" Colors.home else mempty
+          words s = case dropWhile (== '/') s of
+                         "" -> []
+                         s' -> w : words s'' where (w, s'') = break (== '/') s'
+          rest_segs [] = []
+          rest_segs pieces = let last_seg = segment (last pieces) Colors.cwd
+                                 init_segs = [segment piece Colors.path | piece <- init pieces]
+                                 omit_seg = segment Symbols.ellipsis Colors.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 = Symbols.untracked
+    show Conflicted = Symbols.conflicted
+    show NotStaged = Symbols.not_staged
+    show Staged = Symbols.staged
+
+
+git (ExitFailure _, _, _) = mempty
+git (ExitSuccess, out, _) = segment (Symbols.branch ++ " " ++ info) color
+   where
+         color = if dirty then Colors.repo_dirty else Colors.repo_clean
+         dirty = length status_groups > 0
+         info = concat (intersperse " " (status_groups ++ [branch_name]))
+         in_lines = lines out
+         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 (' ':_) = NotStaged
+         code (_:" ") = Staged
+         code _ = Conflicted
+
+render :: [Segment] -> String
+render segments = show whole ++ reset ++ finish ++ Symbols.separator ++ reset ++ " "
+    where whole = foldl (<>) mempty segments
+          finish = fgcolor (bg (right whole))

Symbols.hs

@@ -0,0 +1,16 @@
+module Symbols where
+
+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"