2
\$\begingroup\$

My main concern with this code is this problem - given that this program could generate a prompt string from Bash, Zsh, Fish, etc., I would like to make this code easily extendable so people can add support for a new shell simply by declaring a new Module (or through some similarly easy tactic). The difficulty is that which kind of prompt to build needs to be determined at runtime (currently via a CLI arg). I could require the user to redefine the style for shell prompts for each shell, and then just delegate, but ideally, I would like the user to write their configuration in Main.hs such that they could easily define a generic shell prompt, or reuse segments of a shell prompt configuration, across different shells.

The code below accomplishes this, albeit in maybe not the best way. The current way I'm doing this is creating records of functions and then flipping the record instance variable to the last function argument so that determination of which function implementation to use can be deferred until runtime. The record is defined as ShellType in ShellSegment.hs, and then an instance of that record is created in Zsh.hs. How could I do this better?

(the crux of the code would be Main.hs, ShellSegment.hs, and Zsh.sh, but the rest of the code is provided for context).

The gist of the software is that it stylizes the shell prompt (in the example, just Zsh, but could be configured to style Bash, Sh, Fish, etc.). Future functionality includes styling the TMux status line. Think Lokaltog's Powerline written in Haskell (minus the Vim support due to lack of Haskell bindings for the editor), possibly xmobar and i3.

Main.hs

import LambdaLine.GitComm
import LambdaLine.System
import LambdaLine.LambdaLine
import LambdaLine.Shells.Zsh as Z
import LambdaLine.XTerm.Colors

main :: IO ()
main = exec [ ("Zsh", zshPrompt Z.shell) ]

zshPrompt :: ShellType -> IO ()
zshPrompt = shellPrompt (fgColor slateBlue0 & bold $ " λ» ")

-- Takes the ending char to the prompt as the first argument and applies it
-- as the second to last argument of buildShellPrompt to return a function
-- that recieves the shell type as input
shellPrompt :: (ShellType -> String) -> ShellType -> IO ()
shellPrompt = buildShellPrompt
                        [ bold & fgColor skyBlue `style` mkShellSegment currentDirectory
                        , gitInformationSegment
                        ]
                        (fgColor red0 & bold $ " ➢ ")

gitStatusSegment :: ShellType -> ShellSegment String
gitStatusSegment =
  let unstagedSymbol = fgColor gold1 `style` mkShellSegment (gitUnstagedSymbol "✚")
      stagedSymbol   = fgColor orange `style` mkShellSegment (gitStagedSymbol "✎")
      pushSymbol     = fgColor red1 & bold `style` mkShellSegment (gitPushSymbol "↑")
  in prependSpace `style` (unstagedSymbol <> stagedSymbol <> pushSymbol)

gitInformationSegment :: ShellType -> ShellSegment String
gitInformationSegment =
  let branch = fgColor deepSkyBlue3 & underline & bold `style` mkShellSegment gitCurrentBranch
      repoType = fgColor defaultDarkGreen & bold `style` mkShellSegment (gitRepositorySymbol "±")
  in branch <> repoType <> gitStatusSegment

ShellSegment.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}

module LambdaLine.Shells.ShellSegment
( Segment(..)
, ShellSegment(..)
, ShellType(..)
, (&)
, buildShellPrompt
, mkShellSegment
, style
) where

import LambdaLine.XTerm.Colors(Color)
import Data.Monoid
import Data.Functor
import Control.Applicative
import Data.List(intersperse)
import Data.Maybe(catMaybes)
import LambdaLine.Segment

data ShellSegment a = ShellSegment (IO (Maybe a))

instance Functor ShellSegment where
  fmap f (ShellSegment p) = ShellSegment $ fmap (fmap f) p

instance (Monoid a) => Monoid (ShellSegment a) where
  mempty = ShellSegment $ return mempty
  mappend (ShellSegment s1) (ShellSegment s2) = ShellSegment $ liftA2 (<>) s1 s2

instance Segment ShellSegment String where
  buildPrompt segments separator promptSymbol =
    let sequenceIO           = mapM (\(ShellSegment p) -> p)
        intersperseSeparator = fmap (intersperse separator . catMaybes)
        appendPromptSymbol   = fmap (\segs -> segs ++ [promptSymbol])
    in concat <$> appendPromptSymbol (intersperseSeparator $ sequenceIO segments) >>= putStr
  mkSegment = ShellSegment
  stringToSegment = ShellSegment . return . Just

data ShellType = ShellType
  { appendSpace' :: String -> String
  , bgColor' :: Color ->  String -> String
  , bold' :: String -> String
  , fgColor' :: Color ->  String -> String
  , plain' :: String -> String
  , prependSpace' :: String -> String
  , underline' :: String -> String
  }

-- operator to compose shell prompt styling functions together
(&) :: (String -> ShellType -> String) -> (String -> ShellType -> String)
       -> String -> ShellType -> String
f & g = \str shellType -> g (f str shellType) shellType

buildShellPrompt :: [ShellType -> ShellSegment String]
                      -> (ShellType -> String)
                      -> (ShellType -> String)
                      -> ShellType
                      -> IO ()
buildShellPrompt segmentMakers makeSeparator makePromptSymbol shellType =
  let segments = map (\f -> f shellType) segmentMakers
      separator = makeSeparator shellType
      promptSymbol = makePromptSymbol shellType
  in buildPrompt segments separator promptSymbol

mkShellSegment :: ShellSegment String -> ShellType -> ShellSegment String
mkShellSegment = mkFn (flip plain')
  where mkFn f seg shType = flip f shType <$> seg

style :: (String -> ShellType -> String)
            -> (ShellType -> ShellSegment String)
            -> ShellType -> ShellSegment String
style f makeSegment = flip f >>= \g shellType -> g <$> makeSegment shellType

Zsh.hs

module LambdaLine.Shells.Zsh
( ShellSegment
, ShellType
, (S.&)
, appendSpace
, bgColor
, S.buildShellPrompt
, bold
, fgColor
, S.mkShellSegment
, plain
, prependSpace
, shell
, S.style
, underline
) where
import qualified LambdaLine.Shells.Base as B
import LambdaLine.Shells.ShellSegment as S
import LambdaLine.XTerm.Colors (Color)
import LambdaLine.Util (cycle3)

shell :: ShellType
shell = ShellType
  { appendSpace'  = B.appendSpace
  , bgColor'      = zshBgColor
  , bold'         = B.stylePrompt (\s -> "%B" ++ s ++ "%b")
  , fgColor'      = zshFgColor
  , plain'        = B.plain
  , prependSpace' = B.prependSpace
  , underline'    = B.stylePrompt (\s -> "%U" ++ s ++ "%u")
  }

-- internal definitions to ease readability

zshBgColor :: Color -> String -> String
zshBgColor color = B.stylePrompt (\s -> "%K{" ++ color ++ "}" ++ s ++ "%k")

zshFgColor :: Color -> String -> String
zshFgColor color = B.stylePrompt (\s -> "%F{" ++ color ++ "}" ++ s ++ "%f")

-- exposed methods

appendSpace :: String -> ShellType -> String
appendSpace = flip appendSpace'

bgColor :: Color -> String -> ShellType -> String
bgColor = cycle3 bgColor'

bold :: String -> ShellType -> String
bold = flip bold'

fgColor :: Color -> String -> ShellType -> String
fgColor = cycle3 fgColor'

plain :: String -> ShellType -> String
plain = flip plain'

prependSpace :: String -> ShellType -> String
prependSpace = flip prependSpace'

underline :: String -> ShellType -> String
underline = flip underline'

LambdaLine.hs

module LambdaLine.LambdaLine
( Segment
, (<>)
, buildPrompt
, exec
, fmap
, mkSegment
, mappend
, mempty
, stringToSegment
) where
import Data.Functor
import Data.Monoid
import LambdaLine.Segment
import System.Environment(getArgs)

-- This function allows the user to configure the string they want to use
-- to match up which prompt they want to build.
exec :: [(String, IO())] -> IO ()
exec prompts = getPromptType >>= selectPrompt prompts

-- internal helper functions

selectPrompt :: [(String, IO())] -> String -> IO ()
selectPrompt prompts promptType =
 let findPrompt testPromptName = promptType /= fst testPromptName
 in snd $ head $ dropWhile findPrompt prompts

getPromptType :: IO String
getPromptType = head <$> getArgs

Segment.hs

{-# LANGUAGE MultiParamTypeClasses #-}

module LambdaLine.Segment
(Segment(..)
) where
import Data.Monoid

class (Functor f, Monoid (f a)) => Segment f a where
  buildPrompt :: [f a] -> a -> a -> IO ()
  mkSegment :: IO (Maybe a) -> f a
  stringToSegment :: a -> f a

GitComm.hs

{-# LANGUAGE FlexibleContexts #-}

module LambdaLine.GitComm
( gitCurrentBranch
, gitPushSymbol
, gitRepositorySymbol
, gitStagedSymbol
, gitStatusSymbols
, gitUnstagedSymbol
, inGitRepository
) where
-- internal imports
import LambdaLine.Util
-- import LambdaLine.Segment (Segment, mkSegment)
-- external lib imports
import Control.Monad
import Data.Maybe
import System.Process
import LambdaLine.Shells.ShellSegment

gitCurrentBranch :: Segment f String => f String
gitCurrentBranch =
  mkSegment $ parseProcessResponse $ readProcessWithExitCode "git" ["rev-parse","--abbrev-ref","HEAD"] []

gitPushSymbol :: Segment f String => String -> f String
gitPushSymbol symbol = mkSegment $ hasCommitsToPush >>= calculateStatusSymbol symbol

gitRepositorySymbol :: Segment f String => String -> f String
gitRepositorySymbol symbol = mkSegment $ inGitRepository >>= (\git -> return $ if git
                                                                               then Just symbol
                                                                               else Nothing)

gitStagedSymbol :: Segment f String => String -> f String
gitStagedSymbol symbol = mkSegment $ hasStagedChanges >>= calculateStatusSymbol symbol

I'm not including the rest of this GitComm.hs file because I don't believe it would add insight to the engineering problem I'm attempting to solve.

\$\endgroup\$
3
  • \$\begingroup\$ I've been holding off on making changes to this code. I will not wait longer than this coming Friday, however, so I would appreciate feedback before then if you have any to give. \$\endgroup\$ – Josiah Dec 2 '14 at 22:27
  • \$\begingroup\$ I'm holding out hope that someone will answer this and, thus, planning to work on smaller projects next week rather than this so that if I get feedback, I can still easily apply it. I will consider getting an answer a lost cause on December 12 and apply my own intuitions about how the code could be simplified or performance improved after that date. \$\endgroup\$ – Josiah Dec 7 '14 at 2:50
  • \$\begingroup\$ I narrowed the scope of this question to make it a bit easier to answer. \$\endgroup\$ – Josiah Dec 7 '14 at 20:20

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.