# Delegating which module's functions to use based on user input

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.

• 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. – Josiah Dec 2 '14 at 22:27
• 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. – Josiah Dec 7 '14 at 2:50
• I narrowed the scope of this question to make it a bit easier to answer. – Josiah Dec 7 '14 at 20:20