scrapbook-0.3.2: app/Main.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLabels      #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

module Main where

import           Paths_scrapbook        (version)
import           RIO
import qualified RIO.ByteString         as B
import           RIO.Directory
import           RIO.FilePath

import           Data.Drinkery
import           Data.Extensible
import           Data.Extensible.GetOpt
import           Data.Version           (Version)
import qualified Data.Version           as Version
import           Data.Yaml              (ParseException, decodeEither',
                                         decodeFileEither)
import           Development.GitRev
import           ScrapBook
import           ScrapBook.Cmd

main :: IO ()
main = withGetOpt "[options] [input-file]" opts $ \r args ->
  case toCmd (#input @= args <: r) of
    RunScrapBook opts' -> runScrapBook opts'
    PrintVersion       -> B.putStr $ fromString (showVersion version)
  where
    opts = #output  @= outputOpt
        <: #write   @= writeFormatOpt
        <: #version @= versionOpt
        <: nil

runScrapBook :: Options -> IO ()
runScrapBook opts = tapListT (readInputD opts) $&
  traverseFrom_ consume (fmap liftIO $ writeOutput' opts <=< run' (opts ^. #write))

readInput :: Options -> IO [Either ParseException Config]
readInput opts = sequence $
    case opts ^. #input of
      []    -> pure $ decodeEither' <$> B.getContents
      paths -> decodeFileEither' <$> paths
  where
    decodeFileEither' path =
      fmap (updateFileName (opts ^. #write) path) <$> decodeFileEither path

readInputD :: Options -> ListT () IO (Either ParseException Config)
readInputD = sample <=< liftIO . readInput

writeOutput :: Options -> Config -> Text -> IO ()
writeOutput opts conf txt =
  case opts ^. #output of
    Just dir -> writeFileWithDir (mconcat [dir, "/", name]) txt
    Nothing  -> hPutBuilder stdin $ encodeUtf8Builder txt
  where
    name = fileName conf $ opts ^. #write

writeOutput' :: Options -> (Config, Text) -> IO ()
writeOutput' opts = handle terr . uncurry (writeOutput opts)

showVersion :: Version -> String
showVersion v = unwords
  [ "Version"
  , Version.showVersion v ++ ","
  , "Git revision"
  , $(gitHash)
  , "(" ++ $(gitCommitCount) ++ " commits)"
  ]

terr :: CollectError -> IO ()
terr err = hPutBuilder stderr $ encodeUtf8Builder (tshow err)

writeFileWithDir :: FilePath -> Text -> IO ()
writeFileWithDir path txt = do
  createDirectoryIfMissing True $ dropFileName path
  writeFileUtf8 path txt