diff options
Diffstat (limited to 'src/Main.hs')
-rw-r--r-- | src/Main.hs | 19 |
1 files changed, 17 insertions, 2 deletions
diff --git a/src/Main.hs b/src/Main.hs index c6eee62..06cc6ed 100644 --- a/src/Main.hs +++ b/src/Main.hs | |||
@@ -1,4 +1,4 @@ | |||
1 | {-# LANGUAGE ViewPatterns #-} | 1 | {-# LANGUAGE ViewPatterns, RecordWildCards #-} |
2 | 2 | ||
3 | import Control.Monad | 3 | import Control.Monad |
4 | 4 | ||
@@ -7,6 +7,7 @@ import Control.Lens | |||
7 | import System.Console.Shell | 7 | import System.Console.Shell |
8 | import System.Console.Shell.ShellMonad | 8 | import System.Console.Shell.ShellMonad |
9 | import System.Console.Shell.Backend.Haskeline | 9 | import System.Console.Shell.Backend.Haskeline |
10 | import System.Console.ANSI (setSGRCode, SGR(..), ConsoleLayer(..), ConsoleIntensity(..), ColorIntensity(..), Color(..)) | ||
10 | 11 | ||
11 | import System.Environment.XDG.BaseDir | 12 | import System.Environment.XDG.BaseDir |
12 | import System.FilePath | 13 | import System.FilePath |
@@ -126,8 +127,22 @@ nameEntity :: String -> Sh GameState () | |||
126 | nameEntity ('#':_) = shellPutErrLn "We do not allow names that might shadow explicit access to entities via their number (‘#<n>’)" | 127 | nameEntity ('#':_) = shellPutErrLn "We do not allow names that might shadow explicit access to entities via their number (‘#<n>’)" |
127 | nameEntity name = withFocus $ \ident -> modifying gEntityNames $ Bimap.insert ident (name ^. entityName) | 128 | nameEntity name = withFocus $ \ident -> modifying gEntityNames $ Bimap.insert ident (name ^. entityName) |
128 | 129 | ||
130 | -- Dice rolls | ||
129 | rollTest :: Completable (FormulaM Stats Test) -> Sh GameState () | 131 | rollTest :: Completable (FormulaM Stats Test) -> Sh GameState () |
130 | rollTest = withArg $ enactTest' >=> maybe (return ()) (shellPutStrLn . show) | 132 | rollTest = withArg $ enactTest' >=> maybe (return ()) (shellPutStrLn . ppResult) |
133 | where | ||
134 | ppResult result = pad 3 (show $ result^.rWith) ++ ": " ++ setSGRCode (colour result) ++ name result ++ setSGRCode [] ++ " by " ++ pad 2 (show $ result^.rBy) ++ "pp" | ||
135 | colour CritSuccess{..} = [SetColor Foreground Vivid Green, SetConsoleIntensity BoldIntensity] | ||
136 | colour Success{..} = [SetColor Foreground Dull Green] | ||
137 | colour Failure{..} = [SetColor Foreground Dull Red] | ||
138 | colour CritFailure{..} = [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] | ||
139 | name CritSuccess{..} = "Critical Success" | ||
140 | name Success{..} = "Success" | ||
141 | name Failure{..} = "Failure" | ||
142 | name CritFailure{..} = "Critical Failure" | ||
143 | pad n str | ||
144 | | length str >= n = str | ||
145 | | otherwise = ' ' : pad (n - 1) str | ||
131 | 146 | ||
132 | enactTest' :: (FormulaM Stats Test) -> Sh GameState (Maybe TestResult) | 147 | enactTest' :: (FormulaM Stats Test) -> Sh GameState (Maybe TestResult) |
133 | enactTest' test = withFocus' $ \focus -> do | 148 | enactTest' test = withFocus' $ \focus -> do |