{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Hledger.Cli.Commands.Demo (
demomode
,demo
) where
import Hledger
import Hledger.Cli.CliOptions
import System.Exit (exitFailure)
import Text.Printf
import Control.Concurrent (threadDelay)
import System.Process (callProcess)
import System.IO.Error (catchIOError)
import Safe (readMay, atMay, headMay)
import Data.List (isPrefixOf, find, findIndex, isInfixOf, dropWhileEnd)
import Control.Applicative ((<|>))
import Data.ByteString as B (ByteString)
import Data.Maybe
import qualified Data.ByteString.Char8 as B
import Safe (tailMay)
import System.IO.Temp (withSystemTempFile)
import System.IO (hClose)
import System.Console.CmdArgs.Explicit (flagReq)
demos :: [Demo]
demos :: [Demo]
demos = (ByteString -> Demo) -> [ByteString] -> [Demo]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Demo
readDemo [
$(embedFileRelative "embeddedfiles/add.cast"),
$(embedFileRelative "embeddedfiles/print.cast"),
$(embedFileRelative "embeddedfiles/balance.cast"),
$(embedFileRelative "embeddedfiles/install.cast")
]
data Demo = Demo {
Demo -> String
dtitle :: String,
Demo -> ByteString
_dcontent :: ByteString
}
demomode :: Mode RawOpts
demomode = String
-> [Flag RawOpts]
-> [(String, [Flag RawOpts])]
-> [Flag RawOpts]
-> ([Arg RawOpts], Maybe (Arg RawOpts))
-> Mode RawOpts
hledgerCommandMode
$(embedFileRelative "Hledger/Cli/Commands/Demo.txt")
[
[String] -> Update RawOpts -> String -> String -> Flag RawOpts
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq [String
"speed",String
"s"] (\String
s RawOpts
opts -> RawOpts -> Either String RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either String RawOpts)
-> RawOpts -> Either String RawOpts
forall a b. (a -> b) -> a -> b
$ String -> String -> RawOpts -> RawOpts
setopt String
"speed" String
s RawOpts
opts) String
"SPEED"
(String
"playback speed (1 is original speed, .5 is half, 2 is double, etc (default: 2))")
]
[(String, [Flag RawOpts])
generalflagsgroup3]
[]
([], Arg RawOpts -> Maybe (Arg RawOpts)
forall a. a -> Maybe a
Just (Arg RawOpts -> Maybe (Arg RawOpts))
-> Arg RawOpts -> Maybe (Arg RawOpts)
forall a b. (a -> b) -> a -> b
$ String -> Arg RawOpts
argsFlag String
optsstr)
optsstr :: String
optsstr = String
"[NUM|PREFIX|SUBSTR] [-- ASCIINEMAOPTS]"
usagestr :: String
usagestr = String
"Usage: hledger demo " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
optsstr
demo :: CliOpts -> Journal -> IO ()
demo :: CliOpts -> Journal -> IO ()
demo CliOpts{rawopts_ :: CliOpts -> RawOpts
rawopts_=RawOpts
rawopts, reportspec_ :: CliOpts -> ReportSpec
reportspec_=ReportSpec{_rsQuery :: ReportSpec -> Query
_rsQuery=Query
_query}} Journal
_j = do
case String -> RawOpts -> [String]
listofstringopt String
"args" RawOpts
rawopts of
[] -> String -> IO ()
putStrLn String
usagestr IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
printDemos
(String
a:[String]
as) ->
case [Demo] -> String -> Maybe Demo
findDemo [Demo]
demos String
a of
Maybe Demo
Nothing -> do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"No demo \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" was found."
String -> IO ()
putStrLn String
usagestr
IO ()
printDemos
IO ()
forall a. IO a
exitFailure
Just (Demo String
t ByteString
c) -> do
let
defidlelimit :: Float
defidlelimit = Float
10
defspeed :: Float
defspeed = Float
2
speed :: Float
speed =
case String -> RawOpts -> Maybe String
maybestringopt String
"speed" RawOpts
rawopts of
Maybe String
Nothing -> Float
defspeed
Just String
s -> Float -> Maybe Float -> Float
forall a. a -> Maybe a -> a
fromMaybe Float
forall {a}. a
err (Maybe Float -> Float) -> Maybe Float -> Float
forall a b. (a -> b) -> a -> b
$ String -> Maybe Float
forall a. Read a => String -> Maybe a
readMay String
s
where err :: a
err = String -> a
forall a. String -> a
error' (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"could not parse --speed " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", numeric argument expected"
idx :: Int
idx = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ (Demo -> Bool) -> [Demo] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\(Demo String
t2 ByteString
_) -> String
t2 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
t) [Demo]
demos
Maybe Int
mw <- IO (Maybe Int)
getTerminalWidth
let line :: String
line = String -> String
red' (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
w Char
'.' where w :: Int
w = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
t) Maybe Int
mw
String -> Int -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"playing: %d) %s\nspace to pause, . to step, ctrl-c to quit\n" Int
idx (String -> String
bold' String
t)
String -> IO ()
putStrLn String
line
String -> IO ()
putStrLn String
""
Int -> IO ()
threadDelay Int
1000000
Float -> Float -> ByteString -> [String] -> IO ()
runAsciinemaPlay Float
speed Float
defidlelimit ByteString
c [String]
as
String -> IO ()
putStrLn String
""
String -> IO ()
putStrLn String
line
readDemo :: ByteString -> Demo
readDemo :: ByteString -> Demo
readDemo ByteString
content = String -> ByteString -> Demo
Demo String
title ByteString
content
where
title :: String
title = String -> (ByteString -> String) -> Maybe ByteString -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String -> String
readTitle (String -> String)
-> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack) (Maybe ByteString -> String) -> Maybe ByteString -> String
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Maybe ByteString
forall a. [a] -> Maybe a
headMay ([ByteString] -> Maybe ByteString)
-> [ByteString] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
B.lines ByteString
content
where
readTitle :: String -> String
readTitle String
s
| String
"\"title\":" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'"') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
lstrip (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
8 String
s
| Bool
otherwise = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" String -> String
readTitle (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. [a] -> Maybe [a]
tailMay String
s
findDemo :: [Demo] -> String -> Maybe Demo
findDemo :: [Demo] -> String -> Maybe Demo
findDemo [Demo]
ds String
s =
(String -> Maybe Int
forall a. Read a => String -> Maybe a
readMay String
s Maybe Int -> (Int -> Maybe Demo) -> Maybe Demo
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Demo] -> Int -> Maybe Demo
forall a. [a] -> Int -> Maybe a
atMay [Demo]
ds (Int -> Maybe Demo) -> (Int -> Int) -> Int -> Maybe Demo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1)
Maybe Demo -> Maybe Demo -> Maybe Demo
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Demo -> Bool) -> [Demo] -> Maybe Demo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String
sl String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)(String -> Bool) -> (Demo -> String) -> Demo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
lowercase(String -> String) -> (Demo -> String) -> Demo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Demo -> String
dtitle) [Demo]
ds
Maybe Demo -> Maybe Demo -> Maybe Demo
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Demo -> Bool) -> [Demo] -> Maybe Demo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String
sl String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) (String -> Bool) -> (Demo -> String) -> Demo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
lowercase(String -> String) -> (Demo -> String) -> Demo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Demo -> String
dtitle) [Demo]
ds
where
sl :: String
sl = String -> String
lowercase String
s
printDemos :: IO ()
printDemos :: IO ()
printDemos = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
String
"Demos:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
[Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
bold' String
t | (Int
i, Demo String
t ByteString
_) <- [Int] -> [Demo] -> [(Int, Demo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1::Int)..] [Demo]
demos]
runAsciinemaPlay :: Float -> Float -> ByteString -> [String] -> IO ()
runAsciinemaPlay :: Float -> Float -> ByteString -> [String] -> IO ()
runAsciinemaPlay Float
speed Float
idlelimit ByteString
content [String]
args =
String -> (String -> Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile String
"hledger-cast" ((String -> Handle -> IO ()) -> IO ())
-> (String -> Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
f Handle
h -> do
Handle -> ByteString -> IO ()
B.hPutStr Handle
h ByteString
content IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
h
String -> [String] -> IO ()
callProcess String
"asciinema" (([String] -> String) -> [String] -> [String]
forall a. Show a => (a -> String) -> a -> a
dbg8With ((String
"asciinema: "String -> String -> String
forall a. [a] -> [a] -> [a]
++)(String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[String] -> String
unwords) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
[String
"play"]
,[String
"-s"String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Float -> String
showwithouttrailingzero Float
speed]
,if Float
idlelimit Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 then [] else [String
"-i"String -> String -> String
forall a. Semigroup a => a -> a -> a
<>Float -> String
showwithouttrailingzero Float
idlelimit]
,[String
f]
,[String]
args
])
IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
err -> do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> IOError -> String
forall a. Show a => a -> String
show IOError
err
String -> IO ()
putStrLn String
"Error: running asciinema failed. Trying 'asciinema --version':"
String -> [String] -> IO ()
callProcess String
"asciinema" [String
"--version"] IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
_ ->
String -> IO ()
putStrLn String
"This also failed. Check that asciinema is installed in your PATH."
IO ()
forall a. IO a
exitFailure
where
showwithouttrailingzero :: Float -> String
showwithouttrailingzero = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.') (String -> String) -> (Float -> String) -> Float -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'0') (String -> String) -> (Float -> String) -> Float -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> String
forall a. Show a => a -> String
show