{-# LANGUAGE RankNTypes #-}

module Options.Harg.Util
  ( toDummyOpts,
    allToDummyOpts,
    compose,
    readFileBS,
    readFileLBS,
  )
where

import qualified Barbies as B
import qualified Control.Exception as Exc
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Functor.Compose (Compose (..))
import Data.Functor.Const (Const (..))
import Options.Harg.Het.HList (AssocListF, MapAssocList (..))
import Options.Harg.Types
import System.Directory (doesFileExist)
import System.Exit (exitFailure)

compose ::
  forall f g a.
  ( Functor f,
    B.FunctorB a
  ) =>
  (forall x. x -> g x) ->
  a f ->
  a (Compose f g)
compose :: (forall x. x -> g x) -> a f -> a (Compose f g)
compose to :: forall x. x -> g x
to =
  (forall a. f a -> Compose f g a) -> a f -> a (Compose f g)
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> b f -> b g
B.bmap (f (g a) -> Compose f g a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (f (g a) -> Compose f g a)
-> (f a -> f (g a)) -> f a -> Compose f g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> g a) -> f a -> f (g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> g a
forall x. x -> g x
to)

-- | Convert an option parser into a dummy parser. A dummy option parser always
-- succeeds because options always have a default value (a monoid is used
-- here). This is useful because we want to run the parser together with the
-- configuration parser once in order to gather JSON file paths etc., which
-- means that we still need @--help@ to work.
toDummyOpts ::
  forall m a.
  ( B.FunctorB a,
    Monoid m
  ) =>
  a Opt ->
  a (Compose Opt (Const m))
toDummyOpts :: a Opt -> a (Compose Opt (Const m))
toDummyOpts =
  (forall a. Opt a -> Compose Opt (Const m) a)
-> a Opt -> a (Compose Opt (Const m))
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> b f -> b g
B.bmap forall a. Opt a -> Compose Opt (Const m) a
forall a a a. Monoid a => Opt a -> Compose Opt (Const a) a
toDummy
  where
    toDummy :: Opt a -> Compose Opt (Const a) a
toDummy opt :: Opt a
opt =
      Opt (Const a a) -> Compose Opt (Const a) a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Opt (Const a a) -> Compose Opt (Const a) a)
-> Opt (Const a a) -> Compose Opt (Const a) a
forall a b. (a -> b) -> a -> b
$
        a -> Const a a
forall k a (b :: k). a -> Const a b
Const
          (a -> Const a a) -> Opt a -> Opt (Const a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Opt a
opt
            { _optDefaultVal :: Maybe a
_optDefaultVal =
                a -> Maybe a
forall a. a -> Maybe a
Just a
forall a. Monoid a => a
mempty,
              _optReader :: OptReader a
_optReader =
                a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either String a) -> (String -> a) -> OptReader a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String -> a
forall a b. a -> b -> a
const a
forall a. Monoid a => a
mempty,
              _optType :: OptType a
_optType =
                case Opt a -> OptType a
forall a. Opt a -> OptType a
_optType Opt a
opt of
                  OptionOptType -> OptType a
forall a. OptType a
OptionOptType
                  FlagOptType _ -> a -> OptType a
forall a. a -> OptType a
FlagOptType a
forall a. Monoid a => a
mempty
                  ArgumentOptType -> OptType a
forall a. OptType a
ArgumentOptType
            }

-- | Convert an association list of options in to dummy ones.
allToDummyOpts ::
  forall m ts xs.
  ( Monoid m,
    MapAssocList xs
  ) =>
  AssocListF ts xs Opt ->
  AssocListF ts xs (Compose Opt (Const m))
allToDummyOpts :: AssocListF ts xs Opt -> AssocListF ts xs (Compose Opt (Const m))
allToDummyOpts =
  (forall (a :: (* -> *) -> *).
 FunctorB a =>
 a Opt -> a (Compose Opt (Const m)))
-> AssocListF ts xs Opt -> AssocListF ts xs (Compose Opt (Const m))
forall (as :: [(* -> *) -> *]) (f :: * -> *) (g :: * -> *)
       (ts :: [Symbol]).
MapAssocList as =>
(forall (a :: (* -> *) -> *). FunctorB a => a f -> a g)
-> AssocListF ts as f -> AssocListF ts as g
mapAssocList forall m (a :: (* -> *) -> *).
(FunctorB a, Monoid m) =>
a Opt -> a (Compose Opt (Const m))
forall (a :: (* -> *) -> *).
FunctorB a =>
a Opt -> a (Compose Opt (Const m))
toDummyOpts

printErrAndExit ::
  forall a.
  String ->
  IO a
printErrAndExit :: String -> IO a
printErrAndExit =
  (IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
forall a. IO a
exitFailure) (IO () -> IO a) -> (String -> IO ()) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn

readFileWith ::
  (FilePath -> IO a) ->
  FilePath ->
  IO a
readFileWith :: (String -> IO a) -> String -> IO a
readFileWith f :: String -> IO a
f path :: String
path = do
  Bool
exists <- String -> IO Bool
doesFileExist String
path
  if Bool
exists
    then IO a
readFile_
    else String -> IO a
forall a. String -> IO a
printErrAndExit ("File not found: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path)
  where
    readFile_ :: IO a
readFile_ =
      String -> IO a
f String
path
        IO a -> (IOException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exc.catch` (String -> IO a
forall a. String -> IO a
printErrAndExit (String -> IO a) -> (IOException -> String) -> IOException -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> String
showExc)

    showExc :: Exc.IOException -> String
    showExc :: IOException -> String
showExc exc :: IOException
exc =
      "Could not read file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> IOException -> String
forall e. Exception e => e -> String
Exc.displayException IOException
exc

readFileLBS ::
  FilePath ->
  IO LBS.ByteString
readFileLBS :: String -> IO ByteString
readFileLBS =
  (String -> IO ByteString) -> String -> IO ByteString
forall a. (String -> IO a) -> String -> IO a
readFileWith String -> IO ByteString
LBS.readFile

readFileBS ::
  FilePath ->
  IO BS.ByteString
readFileBS :: String -> IO ByteString
readFileBS =
  (String -> IO ByteString) -> String -> IO ByteString
forall a. (String -> IO a) -> String -> IO a
readFileWith String -> IO ByteString
BS.readFile