herms-1.9.0.2: app/herms.hs
{-# LANGUAGE ViewPatterns #-}
module Main where
import System.Directory
import System.IO
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 Paths_herms
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.2"
configPath :: IO FilePath
configPath = getDataFileName "config.hs"
type HermsReader = ReaderT (Config, RecipeBook)
-- | @getRecipeBookWith reads in recipe book with already read-in config
getRecipeBookWith :: Config -> IO [Recipe]
getRecipeBookWith config = do
fileName <- getDataFileName (recipesFile' config)
contents <- readFile fileName
return $ map read $ lines contents
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]
fileName <- liftIO $ getDataFileName (recipesFile' config)
liftIO $ appendFile fileName (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, recipeBook) <- ask
input <- liftIO $ getAddInput (translator config)
saveOrDiscard input Nothing
doEdit :: Recipe -> Maybe Recipe -> HermsReader IO ()
doEdit recp origRecp = do
(config, recipeBook) <- 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, recipeBook) <- 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
(config,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, recipeBook) <- 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, recipeBook) <- 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 fp str = do
(tempName, tempHandle) <- openTempFile "." "herms_temp"
hPutStr tempHandle str
hClose tempHandle
fileName <- getDataFileName fp
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
(config, 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
dir <- liftIO $ getDataDir
liftIO $ putStrLn $ filter (/= '\"') (show dir) ++ "/"
-- Writes an empty recipes file if it doesn't exist
checkFileExists :: IO ()
checkFileExists = do
config <- getConfig
fileName <- getDataFileName (recipesFile' config)
fileExists <- doesFileExist fileName
unless fileExists (do
dirName <- getDataDir
createDirectoryIfMissing True dirName
writeFile fileName "")
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 directory of recipe file and config.hs
listP, addP, viewP, editP, importP, exportP, 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)