Chapter 5.4 - Options parsing

app/Main.hs

@@ -1,8 +1,60 @@
 -- app/Main.hs
 
+-- | Entry point for the hs-blog-gen program
+
 module Main where
 
 import qualified HsBlog
+import OptParse
+
+import System.Exit (exitFailure)
+import System.Directory (doesFileExist)
+import System.IO
 
 main :: IO ()
-main = HsBlog.main
+main = do
+  options <- parse
+  case options of
+    ConvertDir input output ->
+      HsBlog.convertDirectory input output
+
+    ConvertSingle input output -> do
+      (title, inputHandle) <-
+        case input of
+          Stdin ->
+            pure ("", stdin)
+          InputFile file ->
+            (,) file <$> openFile file ReadMode
+
+      outputHandle <-
+        case output of
+          Stdout -> pure stdout
+          OutputFile file -> do
+            exists <- doesFileExist file
+            shouldOpenFile <-
+              if exists
+                then confirm
+                else pure True
+            if shouldOpenFile
+              then
+                openFile file WriteMode
+              else
+                exitFailure
+
+      HsBlog.convertSingle title inputHandle outputHandle
+      hClose inputHandle
+      hClose outputHandle
+
+------------------------------------------------
+-- * Utilities
+
+-- | Confirm user action
+confirm :: IO Bool
+confirm =
+  putStrLn "Are you sure? (y/n)" *>
+    getLine >>= \answer ->
+      case answer of
+        "y" -> pure True
+        "n" -> pure False
+        _ -> putStrLn "Invalid response. use y or n" *>
+          confirm

app/OptParse.hs

@@ -0,0 +1,137 @@
+-- app/OptParse.hs
+
+-- | Command-line options parsing
+
+module OptParse
+  ( Options(..)
+  , SingleInput(..)
+  , SingleOutput(..)
+  , parse
+  )
+  where
+
+import Data.Maybe (fromMaybe)
+import Options.Applicative
+
+------------------------------------------------
+-- * Our command-line options model
+
+-- | Model
+data Options
+  = ConvertSingle SingleInput SingleOutput
+  | ConvertDir FilePath FilePath
+  deriving Show
+
+-- | A single input source
+data SingleInput
+  = Stdin
+  | InputFile FilePath
+  deriving Show
+
+-- | A single output sink
+data SingleOutput
+  = Stdout
+  | OutputFile FilePath
+  deriving Show
+
+------------------------------------------------
+-- * Parser
+
+-- | Parse command-line options
+parse :: IO Options
+parse = execParser opts
+
+opts :: ParserInfo Options
+opts =
+  info (pOptions <**> helper)
+    ( fullDesc
+      <> header "hs-blog-gen - a static blog generator"
+      <> progDesc "Convert markup files or directories to html"
+    )
+
+-- | Parser for all options
+pOptions :: Parser Options
+pOptions =
+  subparser
+    ( command
+      "convert"
+      ( info
+        (helper <*> pConvertSingle)
+        (progDesc "Convert a single markup source to html")
+      )
+      <> command
+      "convert-dir"
+      ( info
+        (helper <*> pConvertDir)
+        (progDesc "Convert a directory of markup files to html")
+      )
+    )
+
+------------------------------------------------
+-- * Single source to sink conversion parser
+
+-- | Parser for single source to sink option
+pConvertSingle :: Parser Options
+pConvertSingle =
+  ConvertSingle <$> pSingleInput <*> pSingleOutput
+
+-- | Parser for single input source
+pSingleInput :: Parser SingleInput
+pSingleInput =
+  fromMaybe Stdin <$> optional pInputFile
+
+-- | Parser for single output sink
+pSingleOutput :: Parser SingleOutput
+pSingleOutput =
+  fromMaybe Stdout <$> optional pOutputFile
+
+-- | Input file parser
+pInputFile :: Parser SingleInput
+pInputFile = fmap InputFile parser
+  where
+    parser =
+      strOption
+        ( long "input"
+          <> short 'i'
+          <> metavar "FILE"
+          <> help "Input file"
+        )
+
+-- | Output file parser
+pOutputFile :: Parser SingleOutput
+pOutputFile = OutputFile <$> parser
+  where
+    parser =
+      strOption
+        ( long "output"
+          <> short 'o'
+          <> metavar "FILE"
+          <> help "Output file"
+        )
+
+------------------------------------------------
+-- * Directory conversion parser
+
+pConvertDir :: Parser Options
+pConvertDir =
+  ConvertDir <$> pInputDir <*> pOutputDir
+
+-- | Parser for input directory
+pInputDir :: Parser FilePath
+pInputDir =
+  strOption
+    ( long "input"
+      <> short 'i'
+      <> metavar "DIRECTORY"
+      <> help "Input directory"
+    )
+
+-- | Parser for output directory
+pOutputDir :: Parser FilePath
+pOutputDir =
+  strOption
+    ( long "output"
+      <> short 'o'
+      <> metavar "DIRECTORY"
+      <> help "Output directory"
+    )

hs-blog.cabal

@@ -31,7 +31,6 @@ library
   hs-source-dirs: src
   build-depends:
       base
-    , directory
   exposed-modules:
     HsBlog
       HsBlog.Convert
@@ -44,8 +43,12 @@ executable hs-blog-gen
   import: common-settings
   hs-source-dirs: app
   main-is: Main.hs
+  other-modules:
+    OptParse
   build-depends:
       base
+    , directory
+    , optparse-applicative
     , hs-blog
   ghc-options:
     -O

src/HsBlog.hs

@@ -1,7 +1,8 @@
 -- src/HsBlog.hs
 
 module HsBlog
-  ( main
+  ( convertSingle
+  , convertDirectory
   , process
   )
   where
@@ -10,49 +11,15 @@ import qualified HsBlog.Markup as Markup
 import qualified HsBlog.Html as Html
 import HsBlog.Convert (convert)
 
-import System.Directory (doesFileExist)
-import System.Environment (getArgs)
+import System.IO
 
-main :: IO ()
-main = do
-  args <- getArgs
-  case args of
-    -- No program arguments: reading from stdin and writing to stdout
-    [] -> do
-      content <- getContents
-      putStrLn (process "Empty title" content)
+convertSingle :: Html.Title -> Handle -> Handle -> IO ()
+convertSingle title input output = do
+  content <- hGetContents input
+  hPutStrLn output (process title content)
 
-    -- With input and output file paths as program arguments
-    [input, output] -> do
-      content <- readFile input
-      exists <- doesFileExist output
-      let
-        writeResult = writeFile output (process input content)
-      if exists
-        then whenIO confirm writeResult
-        else writeResult
-
-    -- Any other kind of program arguments
-    _ ->
-      putStrLn "Usage: runghc Main.hs [-- <input-file> <output-file>]"
+convertDirectory :: FilePath -> FilePath -> IO ()
+convertDirectory = error "Not implemented"
 
 process :: Html.Title -> String -> String
 process title = Html.render . convert title . Markup.parse
-
-confirm :: IO Bool
-confirm = do
-  putStrLn "Are you sure? (y/n)"
-  answer <- getLine
-  case answer of
-    "y" -> pure True
-    "n" -> pure False
-    _ -> do
-      putStrLn "Invalid response. use y or n"
-      confirm
-
-whenIO :: IO Bool -> IO () -> IO ()
-whenIO cond action = do
-  result <- cond
-  if result
-    then action
-    else pure ()