--------------------------------------------------------------------------------
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE TemplateHaskell #-}
module Patat.Images.W3m
    ( backend
    ) where


--------------------------------------------------------------------------------
import           Control.Exception      (IOException, throwIO, try)
import           Control.Monad          (unless, void)
import qualified Data.Aeson.TH.Extended as A
import           Data.List              (intercalate)
import           Patat.Cleanup          (Cleanup)
import qualified Patat.Images.Internal  as Internal
import qualified System.Directory       as Directory
import qualified System.Process         as Process
import           Text.Read              (readMaybe)


--------------------------------------------------------------------------------
data Config = Config
    { Config -> Maybe FilePath
cPath :: Maybe FilePath
    } deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> FilePath
(Int -> Config -> ShowS)
-> (Config -> FilePath) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Config -> ShowS
showsPrec :: Int -> Config -> ShowS
$cshow :: Config -> FilePath
show :: Config -> FilePath
$cshowList :: [Config] -> ShowS
showList :: [Config] -> ShowS
Show)


--------------------------------------------------------------------------------
$(A.deriveFromJSON A.dropPrefixOptions ''Config)


--------------------------------------------------------------------------------
backend :: Internal.Backend
backend :: Backend
backend = (Config Config -> IO Handle) -> Backend
forall a. FromJSON a => (Config a -> IO Handle) -> Backend
Internal.Backend Config Config -> IO Handle
new


--------------------------------------------------------------------------------
new :: Internal.Config Config -> IO Internal.Handle
new :: Config Config -> IO Handle
new Config Config
config = do
    w3m <- Maybe FilePath -> IO W3m
findW3m (Maybe FilePath -> IO W3m) -> Maybe FilePath -> IO W3m
forall a b. (a -> b) -> a -> b
$ case Config Config
config of
        Internal.Explicit Config
c -> Config -> Maybe FilePath
cPath Config
c
        Config Config
_                   -> Maybe FilePath
forall a. Maybe a
Nothing

    return Internal.Handle {Internal.hDrawImage = drawImage w3m}


--------------------------------------------------------------------------------
newtype W3m = W3m FilePath deriving (Int -> W3m -> ShowS
[W3m] -> ShowS
W3m -> FilePath
(Int -> W3m -> ShowS)
-> (W3m -> FilePath) -> ([W3m] -> ShowS) -> Show W3m
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> W3m -> ShowS
showsPrec :: Int -> W3m -> ShowS
$cshow :: W3m -> FilePath
show :: W3m -> FilePath
$cshowList :: [W3m] -> ShowS
showList :: [W3m] -> ShowS
Show)


--------------------------------------------------------------------------------
findW3m :: Maybe FilePath -> IO W3m
findW3m :: Maybe FilePath -> IO W3m
findW3m = \case
    -- Use the path specified by the user.
    Just FilePath
path -> do
        exe <- FilePath -> IO Bool
isExecutable FilePath
path
        if exe
            then pure $ W3m path
            else throwIO $
                    Internal.BackendNotSupported $ path ++ " is not executable"

    Maybe FilePath
Nothing -> do
        let path :: W3m
path = FilePath -> W3m
W3m FilePath
"w3mimgdisplay"
        errOrSize <- IO (Int, Int) -> IO (Either IOException (Int, Int))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Int, Int) -> IO (Either IOException (Int, Int)))
-> IO (Int, Int) -> IO (Either IOException (Int, Int))
forall a b. (a -> b) -> a -> b
$ W3m -> IO (Int, Int)
getTerminalSize W3m
path
        case errOrSize :: Either IOException (Int, Int) of
            Right (Int, Int)
_ -> W3m -> IO W3m
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure W3m
path          -- Found it.
            Left IOException
_ -> FilePath -> W3m
W3m (FilePath -> W3m) -> IO FilePath -> IO W3m
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath] -> IO FilePath
find [FilePath]
paths  -- Look in some hardcoded paths.
  where
    find :: [FilePath] -> IO FilePath
find []       = BackendNotSupported -> IO FilePath
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (BackendNotSupported -> IO FilePath)
-> BackendNotSupported -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> BackendNotSupported
Internal.BackendNotSupported
        FilePath
"w3mimgdisplay executable not found"
    find (FilePath
p : [FilePath]
ps) = do
        exe <- FilePath -> IO Bool
isExecutable FilePath
p
        if exe then return p else find ps

    paths :: [FilePath]
paths =
        [ FilePath
"/usr/lib/w3m/w3mimgdisplay"
        , FilePath
"/usr/libexec/w3m/w3mimgdisplay"
        , FilePath
"/usr/lib64/w3m/w3mimgdisplay"
        , FilePath
"/usr/libexec64/w3m/w3mimgdisplay"
        , FilePath
"/usr/local/libexec/w3m/w3mimgdisplay"
        ]

    isExecutable :: FilePath -> IO Bool
isExecutable FilePath
path = do
        exists <- FilePath -> IO Bool
Directory.doesFileExist FilePath
path
        if exists then do
            perms <- Directory.getPermissions path
            return (Directory.executable perms)
        else
            return False


--------------------------------------------------------------------------------
-- | Parses something of the form "<width> <height>\n".
parseWidthHeight :: String -> Maybe (Int, Int)
parseWidthHeight :: FilePath -> Maybe (Int, Int)
parseWidthHeight FilePath
output = case FilePath -> [FilePath]
words FilePath
output of
    [FilePath
ws, FilePath
hs] | Just Int
w <- FilePath -> Maybe Int
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
ws, Just Int
h <- FilePath -> Maybe Int
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
hs ->
        (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
w, Int
h)
    [FilePath]
_  -> Maybe (Int, Int)
forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
getTerminalSize :: W3m -> IO (Int, Int)
getTerminalSize :: W3m -> IO (Int, Int)
getTerminalSize (W3m FilePath
w3mPath) = do
    output <- FilePath -> [FilePath] -> FilePath -> IO FilePath
Process.readProcess FilePath
w3mPath [FilePath
"-test"] FilePath
""
    case parseWidthHeight output of
        Just (Int, Int)
wh -> (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int, Int)
wh
        Maybe (Int, Int)
_       -> FilePath -> IO (Int, Int)
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO (Int, Int)) -> FilePath -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$
            FilePath
"Patat.Images.W3m.getTerminalSize: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
            FilePath
"Could not parse `w3mimgdisplay -test` output"


--------------------------------------------------------------------------------
getImageSize :: W3m -> FilePath -> IO (Int, Int)
getImageSize :: W3m -> FilePath -> IO (Int, Int)
getImageSize (W3m FilePath
w3mPath) FilePath
path = do
    output <- FilePath -> [FilePath] -> FilePath -> IO FilePath
Process.readProcess FilePath
w3mPath [] (FilePath
"5;" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
path FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"\n")
    case parseWidthHeight output of
        Just (Int, Int)
wh -> (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int, Int)
wh
        Maybe (Int, Int)
_       -> FilePath -> IO (Int, Int)
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO (Int, Int)) -> FilePath -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$
            FilePath
"Patat.Images.W3m.getImageSize: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
            FilePath
"Could not parse image size using `w3mimgdisplay` for " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
            FilePath
path


--------------------------------------------------------------------------------
drawImage :: W3m -> FilePath -> IO Cleanup
drawImage :: W3m -> FilePath -> IO Cleanup
drawImage w3m :: W3m
w3m@(W3m FilePath
w3mPath) FilePath
path = do
    exists <- FilePath -> IO Bool
Directory.doesFileExist FilePath
path
    unless exists $ fail $
        "Patat.Images.W3m.drawImage: file does not exist: " ++ path

    tsize <- getTerminalSize w3m
    isize <- getImageSize w3m path
    let (x, y, w, h) = fit tsize isize
        command =
            FilePath
"0;1;" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
            Int -> FilePath
forall a. Show a => a -> FilePath
show Int
x FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
";" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
y FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
";" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
w FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
";" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
h FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
            FilePath
";;;;;" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
path FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"\n4;\n3;\n"

    -- Draw image.
    _ <- Process.readProcess w3mPath [] command

    -- Return a 'Cleanup' that clears the image.
    return $ void $ Process.readProcess w3mPath [] $
        "6;" ++ intercalate ";" (map show [x, y, w, h])
  where
    fit :: (Int, Int) -> (Int, Int) -> (Int, Int, Int, Int)
    fit :: (Int, Int) -> (Int, Int) -> (Int, Int, Int, Int)
fit (Int
tw, Int
th) (Int
iw0, Int
ih0) =
        -- Scale down to width
        let iw1 :: Int
iw1 = if Int
iw0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
tw then Int
tw else Int
iw0
            ih1 :: Int
ih1 = if Int
iw0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
tw then ((Int
ih0 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
tw) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
iw0) else Int
ih0

        -- Scale down to height
            iw2 :: Int
iw2 = if Int
ih1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
th then ((Int
iw1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
th) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
ih1) else Int
iw1
            ih2 :: Int
ih2 = if Int
ih1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
th then Int
th else Int
ih1

        -- Find position
            x :: Int
x = (Int
tw Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
iw2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
            y :: Int
y = (Int
th Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ih2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 in

         (Int
x, Int
y, Int
iw2, Int
ih2)