module Buchhaltung.Ask where
import Buchhaltung.Types
import Control.Arrow
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Trans.Class
import Data.Char
import Data.Function
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Monoid
import qualified Data.Text as T
import Hledger.Data.Types
import System.Console.Haskeline
import System.Console.Haskeline.History
editLoop :: MonadException m =>
(T.Text -> Either String c)
-> String
-> Maybe (c, T.Text)
-> Maybe [T.Text]
-> Either T.Text T.Text
-> Maybe T.Text
-> m c
editLoop extractor = editLoopM $ return . extractor
editLoopM :: MonadException m =>
(T.Text -> m (Either String c))
-> String
-> Maybe (c, T.Text)
-> Maybe [T.Text]
-> Either T.Text T.Text
-> Maybe T.Text
-> m c
editLoopM extract histFileSuf def completionList prompt init =
runInputT2 settings loop
where loop = do s <- fromJust <$> getInput
let useDef = if s=="" then Just fst else Nothing
tryExtract = do
modifyHistory $ addHistoryRemovingAllDupes s
either ((>> loop) . outputStr . (++"\n")) return =<<
(lift $ extract $ T.pack s)
maybe tryExtract return $ useDef <*> def
getInput = getInputLineWithInitial (T.unpack prompt')
(maybe "" T.unpack init, "")
prompt' = either (<>(maybe ": " (\x -> " ["<> snd x <>"]: ") def)) id prompt :: T.Text
settings = Settings { historyFile = histFile histFileSuf
,complete = completeFunc, autoAddHistory = False }
completeFunc = maybe noCompletion (customCompl . fmap T.unpack)
completionList
customCompl list = completeWord Nothing ""
$ \s -> return $ map (g s) $ filter (on f (toLower<$>) s) list
where g s x = Completion y x False
where y = concat $ "" : tail (ciSplitOn s x)
f s = (||) <$> isPrefixOf s <*> isInfixOf (":"++s)
histFile suf = Just $ ".haskeline_history_"++suf
newtype CiChar = CiChar { ciChar :: Char }
instance Eq CiChar where
(==) = (==) `on` (toLower . ciChar)
ciSplitOn s x = (ciChar<$>) <$> (on (split . onSublist) (CiChar<$>) s x)
myGetchar :: IO Char
myGetchar = fromJust <$> runInputT2 defaultSettings ( getInputChar "your action: ")
runInputT2 s i = runInputT s $ withInterrupt $ handle
(\Interrupt -> outputStrLn "you will loose all unsaved data!" >> i) i
editHaskeline :: (a -> String) -> (a -> String -> a) -> a -> IO a
editHaskeline show modify v = liftM (modify v . fromJust) $
runInputT2 defaultSettings{historyFile = Just ".haskeline_history"} $
getInputLineWithInitial "edit: " (show v,"")
askAccount :: (MonadReader (Options User config env) m, MonadIO m)
=> [AccountName]
-> Maybe AccountName
-> Maybe String
-> Either T.Text T.Text
-> m AccountName
askAccount completionList def suf pr = do
revAccount <- askReverseAccount
fmap revAccount . liftIO $ editLoop (maybe notNull (const Right) def)
(fromMaybe "Account" suf)
((id &&& id) . revAccount <$> def)
(Just $ revAccount <$> completionList) pr Nothing --def
where notNull s = if s=="" then Left "Blank Account not allowed"
else Right s
askReverseAccount :: MonadReader (Options User config env) m => m (T.Text -> T.Text)
askReverseAccount = g <$> readUser reverseAccountInput
where g x = if fromMaybe True x then T.intercalate ":" . reverse . T.splitOn ":"
else id