herms-1.9.0.4: app/herms.hs
{-# LANGUAGE ViewPatterns #-}
module Main where
import System.IO
import System.Directory
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Function
import Data.List
import Data.Maybe
import Data.Semigroup ((<>))
import Data.String (IsString(..))
import Data.Ratio
import Control.Applicative
import Options.Applicative hiding (str)
import Text.Read
import Utils
import AddCLI
import RichText
import Types
import UnitConversions
import ReadConfig
import Control.Exception
import GHC.IO.Exception
import Foreign.C.Error
import qualified Lang.Strings as Str
-- Global constants
versionStr :: String
versionStr = "1.9.0.4"
type HermsReader = ReaderT (Config, RecipeBook)
-- | @getRecipeBookWith reads in recipe book with already read-in config
getRecipeBookWith :: Config -> IO [Recipe]
getRecipeBookWith config =
fmap (map read . lines) $
readFileOrDefault "recipes.herms" (recipesFile' config)
getRecipe :: String -> [Recipe] -> Maybe Recipe
getRecipe target = listToMaybe . filter ((target ==) . recipeName)
saveOrDiscard :: [[String]] -- input for the new recipe
-> Maybe Recipe -- maybe an original recipe prior to any editing
-> HermsReader IO ()
saveOrDiscard input oldRecp = do
(config, recipeBook) <- ask
let t = translator config
let newRecipe = readRecipe input
liftIO $ putTextLn $ showRecipe t newRecipe Nothing
liftIO $ putStrLn (t Str.saveRecipeYesNoEdit)
response <- liftIO getLine
if response == t Str.y || response == t Str.yCap
then do
let recpName = maybe (recipeName newRecipe) recipeName oldRecp
unless (isNothing (readRecipeRef recpName recipeBook)) $ removeSilent [recpName]
liftIO $ appendFile (recipesFile' config) (show newRecipe ++ "\n")
liftIO $ putStrLn (t Str.recipeSaved)
else if response == t Str.n || response == t Str.nCap
then
liftIO $ putStrLn (t Str.changesDiscarded)
else if response == t Str.e || response == t Str.eCap
then
doEdit newRecipe oldRecp
else
do
liftIO $ putStrLn ("\n" ++ t Str.badEntry ++ "\n")
saveOrDiscard input oldRecp
add :: HermsReader IO ()
add = do
(config, _) <- ask
input <- liftIO $ getAddInput (translator config)
saveOrDiscard input Nothing
doEdit :: Recipe -> Maybe Recipe -> HermsReader IO ()
doEdit recp origRecp = do
(config, _) <- ask
input <- liftIO $ getEdit (translator config) (recipeName recp) (description recp) serving amounts units ingrs attrs dirs tag
saveOrDiscard input origRecp
where serving = show $ servingSize recp
ingrList = adjustIngredients (servingSize recp % 1) $ ingredients recp
toStr f = unlines (map f ingrList)
amounts = toStr (showFrac . quantity)
units = toStr unit
ingrs = toStr ingredientName
dirs = unlines (directions recp)
attrs = toStr attribute
tag = unwords (tags recp)
edit :: String -> HermsReader IO ()
edit target = do
(config, recipeBook) <- ask
let t = translator config
case readRecipeRef target recipeBook of
Nothing -> liftIO $ putStrLn $ target ++ t Str.doesNotExist
Just recp -> doEdit recp (Just recp)
-- Only supports editing one recipe per command
-- | `readRecipeRef target book` interprets the string `target`
-- as either an index or a recipe's name and looks up the
-- corresponding recipe in the `book`
readRecipeRef :: String -> [Recipe] -> Maybe Recipe
readRecipeRef target recipeBook =
(safeLookup recipeBook . pred =<< readMaybe target)
<|> getRecipe target recipeBook
importFile :: String -> HermsReader IO ()
importFile target = do
(config, recipeBook) <- ask
let t = translator config
otherRecipeBook <- liftIO $ map read . lines <$> readFile target
let recipeEq = (==) `on` recipeName
let newRecipeBook = deleteFirstsBy recipeEq recipeBook otherRecipeBook
++ otherRecipeBook
liftIO $ replaceDataFile (recipesFile' config) $ unlines $ show <$> newRecipeBook
liftIO $ if null otherRecipeBook
then putStrLn (t Str.nothingToImport)
else do
putStrLn (t Str.importedRecipes)
forM_ otherRecipeBook $ \recipe ->
putStrLn $ " " ++ recipeName recipe
export :: [String] -> HermsReader IO ()
export targets = do
(config, recipeBook) <- ask
let t = translator config
liftIO $ forM_ targets $ \ target ->
putText $ case readRecipeRef target recipeBook of
Nothing -> target ~~ t Str.doesNotExist
Just recp -> fromString $ show recp
getServingsAndConv :: Int -> String -> Config -> (Maybe Int, Conversion)
getServingsAndConv serv convName config = (servings, conv)
where servings = case serv of
0 -> case defaultServingSize' config of
0 -> Nothing
j -> Just j
i -> Just i
t = translator config
conv
| convName == t Str.metric = Metric
| convName == t Str.imperial = Imperial
| otherwise = defaultUnit' config
view :: [String] -> Int -> String -> HermsReader IO ()
view targets serv convName = do
(config, recipeBook) <- ask
let t = translator config
let (servings, conv) = getServingsAndConv serv convName config
liftIO $ forM_ targets $ \ target ->
putText $ case readRecipeRef target recipeBook of
Nothing -> target ~~ t Str.doesNotExist
Just recp -> showRecipe t (convertRecipeUnits conv recp) servings
viewByStep :: [String] -> Int -> String -> HermsReader IO ()
viewByStep targets serv convName = do
(config, recipeBook) <- ask
let t = translator config
let (servings, conv) = getServingsAndConv serv convName config
liftIO $ hSetBuffering stdout NoBuffering
forM_ targets $ \ target -> case readRecipeRef target recipeBook of
Nothing -> liftIO $ putStr $ target ++ t Str.doesNotExist
Just recp -> viewRecipeByStep (convertRecipeUnits conv recp) servings
viewRecipeByStep :: Recipe -> Maybe Int -> HermsReader IO ()
viewRecipeByStep recp servings = do
(config, _) <- ask
let t = translator config
liftIO $ putText $ showRecipeHeader t recp servings
let steps = showRecipeSteps recp
liftIO $ forM_ (init steps) $ \ step -> do
putStr $ step ++ t Str.more
getLine
liftIO $ putStr $ last steps ++ "\n"
list :: [String] -> Bool -> Bool -> HermsReader IO ()
list inputTags groupByTags nameOnly = do
(_, recipes) <- ask
let recipesWithIndex = zip [1..] recipes
let targetRecipes = filterByTags inputTags recipesWithIndex
if groupByTags
then listByTags nameOnly inputTags targetRecipes
else listDefault nameOnly targetRecipes
filterByTags :: [String] -> [(Int, Recipe)] -> [(Int, Recipe)]
filterByTags [] = id
filterByTags inputTags = filter (inTags . tags . snd)
where
inTags r = all (`elem` r) inputTags
listDefault :: Bool -> [(Int, Recipe)] -> HermsReader IO ()
listDefault nameOnly (unzip -> (indices, recipes)) = do
(config, _) <- ask
let recipeList = map (showRecipeInfo (translator config)) recipes
size = length $ show $ length recipeList
strIndices = map (padLeft size . show) indices
liftIO $ if nameOnly
then mapM_ (putStrLn . recipeName) recipes
else mapM_ putTextLn $ zipWith (\ i -> ((i ~~ ". ") ~~)) strIndices recipeList
listByTags :: Bool -> [String] -> [(Int, Recipe)] -> HermsReader IO ()
listByTags nameOnly inputTags recipesWithIdx = do
(config, _) <- ask
let tagsRecipes :: [[(String, (Int, Recipe))]]
tagsRecipes =
groupBy ((==) `on` fst) $ sortBy (compare `on` fst) $
concat $ flip map recipesWithIdx $ \recipeWithIdx ->
map (flip (,) recipeWithIdx) $ tags $ snd recipeWithIdx
liftIO $ forM_ tagsRecipes $ \tagRecipes -> do
putTextLn $ bold $ fontColor Magenta $ fst $ head tagRecipes -- Tag name
forM_ (map snd tagRecipes) $ \(i, recipe) ->
if nameOnly
then putStrLn $ recipeName recipe
else putTextLn $ " " ~~ show i ~~ ". " ~~ showRecipeInfo (translator config) recipe
putStrLn ""
showRecipeInfo :: Translator -> Recipe -> RichText
showRecipeInfo t recipe = name ~~ "\n\t" ~~ desc ~~ "\n\t[" ~~ tagsStr ~~ ": " ~~ showTags ~~ "]"
where name = fontColor Blue $ recipeName recipe
desc = (takeFullWords . description) recipe
showTags = fontColor Green $ (intercalate ", " . tags) recipe
tagsStr = fontColor White (t Str.capTags)
takeFullWords :: String -> String
takeFullWords = unwords . takeFullWords' 0 . words
where takeFullWords' _ [] = []
takeFullWords' n [x] | (length x + n) > 40 = []
| otherwise = [x]
takeFullWords' n (x:xs) | (length x + n) > 40 = [x ++ "..."]
| otherwise =
x : takeFullWords' (length x + n) xs
-- | @replaceDataFile fp str@ replaces the target data file @fp@ with
-- the new content @str@ in a safe manner: it opens a temporary file
-- first, writes to it, closes the handle, removes the target,
-- and finally moves the temporary file over to the target @fp@.
replaceDataFile :: FilePath -> String -> IO ()
replaceDataFile fileName str = do
(tempName, tempHandle) <- openTempFile "." "herms_temp"
hPutStr tempHandle str
hClose tempHandle
removeFile fileName
let exdev e = if ioe_errno e == Just ((\(Errno a) -> a) eXDEV)
then copyFile tempName fileName >> removeFile tempName
else throw e
renameFile tempName fileName `catch` exdev
-- | @removeWithVerbosity v recipes@ deletes the @recipes@ from the
-- book, listing its work only if @v@ is set to @True@.
-- This subsumes both @remove@ and @removeSilent@.
removeWithVerbosity :: Bool -> [String] -> HermsReader IO ()
removeWithVerbosity v targets = do
(config, recipeBook) <- ask
let t = translator config
mrecipes <- liftIO $ forM targets $ \ target -> do
-- Resolve the recipes all at once; this way if we remove multiple
-- recipes based on their respective index, all of the index are
-- resolved based on the state the book was in before we started to
-- remove anything
let mrecp = readRecipeRef target recipeBook
() <- putStr $ case mrecp of
Nothing -> target ++ t Str.doesNotExist
Just r -> guard v *> t Str.removingRecipe ++ recipeName r ++ "...\n"
return mrecp
-- Remove all the resolved recipes at once
let newRecipeBook = recipeBook \\ catMaybes mrecipes
liftIO $ replaceDataFile (recipesFile' config) $ unlines $ show <$> newRecipeBook
remove :: [String] -> HermsReader IO ()
remove = removeWithVerbosity True
removeSilent :: [String] -> HermsReader IO ()
removeSilent = removeWithVerbosity False
shop :: [String] -> Int -> HermsReader IO ()
shop targets serv = do
(_, recipeBook) <- ask
let getFactor recp
| serv == 0 = servingSize recp % 1
| otherwise = serv % 1
let ingrts =
concatMap (\target ->
case readRecipeRef target recipeBook of
Nothing -> []
Just recp -> adjustIngredients (getFactor recp) $ ingredients recp)
targets
liftIO $ forM_ (sort ingrts) $ \ingr ->
putStrLn $ showIngredient 1 ingr
printDataDir :: HermsReader IO ()
printDataDir = do
(config, _) <- ask
liftIO $ mapM_ (putStrLn . cleanDirPath) [dataDir config, configDir config]
where cleanDirPath = (++ "/") . filter (/= '\"')
main :: IO ()
main = do
config <- getConfig
recipeBook <- getRecipeBookWith config
command <- execParser (commandPI (translator config))
runReaderT (runWithOpts command) (config, recipeBook)
-- @runWithOpts runs the action of selected command.
runWithOpts :: Command -> HermsReader IO ()
runWithOpts (List tags group nameOnly) = list tags group nameOnly
runWithOpts Add = add
runWithOpts (Edit target) = edit target
runWithOpts (Import target) = importFile target
runWithOpts (Export targets) = export targets
runWithOpts (Remove targets) = remove targets
runWithOpts (View targets serving step conversion) = if step
then viewByStep targets serving conversion
else view targets serving conversion
runWithOpts (Shop targets serving) = shop targets serving
runWithOpts DataDir = printDataDir
------------------------------
------------ CLI -------------
------------------------------
-- | 'Command' data type represents commands of CLI
data Command = List [String] Bool Bool -- ^ shows recipes
| View [String] Int Bool String -- ^ shows specified recipes with given serving
| Add -- ^ adds the recipe (interactively)
| Edit String -- ^ edits the recipe
| Import String -- ^ imports a recipe file
| Export [String] -- ^ exports recipes to stdout
| Remove [String] -- ^ removes specified recipes
| Shop [String] Int -- ^ generates the shopping list for given recipes
| DataDir -- ^ prints the directories of recipe file and config.hs
listP, addP, viewP, editP, importP, exportP, removeP, shopP, dataDirP :: Translator -> Parser Command
listP t = List <$> (words <$> tagsP t) <*> groupByTagsP t <*> nameOnlyP t
addP _ = pure Add
editP t = Edit <$> recipeNameP t
importP t = Import <$> fileNameP t
exportP t = Export <$> severalRecipesP t
removeP t = Remove <$> severalRecipesP t
viewP t = View <$> severalRecipesP t <*> servingP t <*> stepP t <*> conversionP t
shopP t = Shop <$> severalRecipesP t <*> servingP t
dataDirP _ = pure DataDir
-- | @groupByTagsP is flag for grouping recipes by tags
groupByTagsP :: Translator -> Parser Bool
groupByTagsP t = switch
( long (t Str.group)
<> short Str.groupShort
<> help (t Str.groupDesc)
)
-- | @nameOnlyP is flag for showing recipe names only
nameOnlyP :: Translator -> Parser Bool
nameOnlyP t = switch
( long (t Str.nameOnly)
<> short Str.nameOnlyShort
<> help (t Str.nameOnlyDesc)
)
-- | @tagsP returns the parser of tags
tagsP :: Translator -> Parser String
tagsP t = strOption (long (t Str.tags)
<> value ""
<> metavar (t Str.tagsMetavar)
<> help (t Str.tagsDesc)
)
-- | @servingP returns the parser of number of servings.
servingP :: Translator -> Parser Int
servingP t = option auto
( long (t Str.serving)
<> short Str.servingShort
<> help (t Str.servingDesc)
<> showDefault
<> value 0
<> metavar (t Str.servingMetavar) )
stepP :: Translator -> Parser Bool
stepP t = switch
( long (t Str.step)
<> short Str.stepShort
<> help (t Str.stepDesc) )
-- | @recipeNameP parses the string of recipe name.
recipeNameP :: Translator -> Parser String
recipeNameP t = strArgument ( metavar (t Str.recipeNameMetavar)
<> help (t Str.recipeNameDesc))
-- | @fileNameP parses the string of a file name.
fileNameP :: Translator -> Parser String
fileNameP t = strArgument ( metavar (t Str.fileNameMetavar)
<> help (t Str.fileNameDesc))
-- | @severalRecipesP parses several recipe names at once
-- and returns the parser of list of names
severalRecipesP :: Translator -> Parser [String]
severalRecipesP t = many (recipeNameP t)
-- | @conversionP flags recipes for unit conversion
conversionP :: Translator -> Parser String
conversionP t = strOption
(long (t Str.convert)
<> short Str.convertShort
<> help (t Str.convertDesc)
<> metavar (t Str.convertMetavar)
<> value (t Str.none))
-- @optP parses particular command.
optP :: Translator -> Parser Command
optP t = subparser
$ command (t Str.list)
(info (helper <*> listP t)
(progDesc (t Str.listDesc)))
<> command (t Str.view)
(info (helper <*> viewP t)
(progDesc (t Str.viewDesc)))
<> command (t Str.add)
(info (helper <*> addP t)
(progDesc (t Str.addDesc)))
<> command (t Str.edit)
(info (helper <*> editP t)
(progDesc (t Str.editDesc)))
<> command (t Str.import')
(info (helper <*> importP t)
(progDesc (t Str.importDesc)))
<> command (t Str.export)
(info (helper <*> exportP t)
(progDesc (t Str.exportDesc)))
<> command (t Str.remove)
(info (helper <*> removeP t)
(progDesc (t Str.removeDesc)))
<> command (t Str.shopping)
(info (helper <*> shopP t)
(progDesc (t Str.shoppingDesc)))
<> command (t Str.datadir)
(info (helper <*> dataDirP t)
(progDesc (t Str.datadirDesc)))
versionOption :: Parser (a -> a)
versionOption = infoOption versionStr
(long "version"
<> short 'v'
<> help "Show version")
-- @prsr is the main parser of all CLI arguments.
commandPI :: Translator -> ParserInfo Command
commandPI t = info ( helper <*> versionOption <*> optP t)
$ fullDesc
<> progDesc (t Str.progDesc)