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

    Handle -> IO Handle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Internal.Handle {hDrawImage :: FilePath -> IO Cleanup
Internal.hDrawImage = W3m -> FilePath -> IO Cleanup
drawImage W3m
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
        Bool
exe <- FilePath -> IO Bool
isExecutable FilePath
path
        if Bool
exe
            then W3m -> IO W3m
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (W3m -> IO W3m) -> W3m -> IO W3m
forall a b. (a -> b) -> a -> b
$ FilePath -> W3m
W3m FilePath
path
            else BackendNotSupported -> IO W3m
forall e a. Exception e => e -> IO a
throwIO (BackendNotSupported -> IO W3m) -> BackendNotSupported -> IO W3m
forall a b. (a -> b) -> a -> b
$
                    FilePath -> BackendNotSupported
Internal.BackendNotSupported (FilePath -> BackendNotSupported)
-> FilePath -> BackendNotSupported
forall a b. (a -> b) -> a -> b
$ FilePath
path FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" is not executable"

    Maybe FilePath
Nothing -> do
        let path :: W3m
path = FilePath -> W3m
W3m FilePath
"w3mimgdisplay"
        Either IOException (Int, Int)
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 Either IOException (Int, Int)
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. 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
        Bool
exe <- FilePath -> IO Bool
isExecutable FilePath
p
        if Bool
exe then FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
p else [FilePath] -> IO FilePath
find [FilePath]
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
        Bool
exists <- FilePath -> IO Bool
Directory.doesFileExist FilePath
path
        if Bool
exists then do
            Permissions
perms <- FilePath -> IO Permissions
Directory.getPermissions FilePath
path
            Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Permissions -> Bool
Directory.executable Permissions
perms)
        else
            Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
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
    FilePath
output <- FilePath -> [FilePath] -> FilePath -> IO FilePath
Process.readProcess FilePath
w3mPath [FilePath
"-test"] FilePath
""
    case FilePath -> Maybe (Int, Int)
parseWidthHeight FilePath
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
    FilePath
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 FilePath -> Maybe (Int, Int)
parseWidthHeight FilePath
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
    Bool
exists <- FilePath -> IO Bool
Directory.doesFileExist FilePath
path
    Bool -> Cleanup -> Cleanup
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (Cleanup -> Cleanup) -> Cleanup -> Cleanup
forall a b. (a -> b) -> a -> b
$ FilePath -> Cleanup
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Cleanup) -> FilePath -> Cleanup
forall a b. (a -> b) -> a -> b
$
        FilePath
"Patat.Images.W3m.drawImage: file does not exist: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
path

    (Int, Int)
tsize <- W3m -> IO (Int, Int)
getTerminalSize W3m
w3m
    (Int, Int)
isize <- W3m -> FilePath -> IO (Int, Int)
getImageSize W3m
w3m FilePath
path
    let (Int
x, Int
y, Int
w, Int
h) = (Int, Int) -> (Int, Int) -> (Int, Int, Int, Int)
fit (Int, Int)
tsize (Int, Int)
isize
        command :: FilePath
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.
    FilePath
_ <- FilePath -> [FilePath] -> FilePath -> IO FilePath
Process.readProcess FilePath
w3mPath [] FilePath
command

    -- Return a 'Cleanup' that clears the image.
    Cleanup -> IO Cleanup
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cleanup -> IO Cleanup) -> Cleanup -> IO Cleanup
forall a b. (a -> b) -> a -> b
$ IO FilePath -> Cleanup
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO FilePath -> Cleanup) -> IO FilePath -> Cleanup
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath -> IO FilePath
Process.readProcess FilePath
w3mPath [] (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$
        FilePath
"6;" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
";" ((Int -> FilePath) -> [Int] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Int -> FilePath
forall a. Show a => a -> FilePath
show [Int
x, Int
y, Int
w, Int
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)