{-# 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)