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


--------------------------------------------------------------------------------
import           Control.Exception      (throwIO)
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)


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


--------------------------------------------------------------------------------
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
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> FilePath
$cshow :: Config -> FilePath
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)


--------------------------------------------------------------------------------
new :: Internal.Config Config -> IO Internal.Handle
new :: Config Config -> IO Handle
new config :: 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 c :: Config
c -> Config -> Maybe FilePath
cPath Config
c
        _                   -> Maybe FilePath
forall a. Maybe a
Nothing

    Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle :: (FilePath -> IO Cleanup) -> Handle
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
showList :: [W3m] -> ShowS
$cshowList :: [W3m] -> ShowS
show :: W3m -> FilePath
$cshow :: W3m -> FilePath
showsPrec :: Int -> W3m -> ShowS
$cshowsPrec :: Int -> W3m -> ShowS
Show)


--------------------------------------------------------------------------------
findW3m :: Maybe FilePath -> IO W3m
findW3m :: Maybe FilePath -> IO W3m
findW3m mbPath :: Maybe FilePath
mbPath
    | Just path :: FilePath
path <- Maybe FilePath
mbPath = do
        Bool
exe <- FilePath -> IO Bool
isExecutable FilePath
path
        if Bool
exe
            then W3m -> IO W3m
forall (m :: * -> *) a. Monad m => a -> m a
return (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]
++ " is not executable"
    | Bool
otherwise = 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
  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
        "w3mimgdisplay executable not found"
    find (p :: FilePath
p : ps :: [FilePath]
ps) = do
        Bool
exe <- FilePath -> IO Bool
isExecutable FilePath
p
        if Bool
exe then FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
p else [FilePath] -> IO FilePath
find [FilePath]
ps

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

    isExecutable :: FilePath -> IO Bool
isExecutable path :: 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 (m :: * -> *) a. Monad m => a -> m a
return (Permissions -> Bool
Directory.executable Permissions
perms)
        else
            Bool -> IO Bool
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 output :: FilePath
output = case FilePath -> [FilePath]
words FilePath
output of
    [ws :: FilePath
ws, hs :: FilePath
hs] | Just w :: Int
w <- FilePath -> Maybe Int
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
ws, Just h :: Int
h <- FilePath -> Maybe Int
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
hs ->
        (Int, Int) -> Maybe (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
w, Int
h)
    _  -> Maybe (Int, Int)
forall a. Maybe a
Nothing


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


--------------------------------------------------------------------------------
getImageSize :: W3m -> FilePath -> IO (Int, Int)
getImageSize :: W3m -> FilePath -> IO (Int, Int)
getImageSize (W3m w3mPath :: FilePath
w3mPath) path :: FilePath
path = do
    FilePath
output <- FilePath -> [FilePath] -> FilePath -> IO FilePath
Process.readProcess FilePath
w3mPath [] ("5;" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
path FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n")
    case FilePath -> Maybe (Int, Int)
parseWidthHeight FilePath
output of
        Just wh :: (Int, Int)
wh -> (Int, Int) -> IO (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int, Int)
wh
        _       -> FilePath -> IO (Int, Int)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO (Int, Int)) -> FilePath -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$
            "Patat.Images.W3m.getImageSize: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
            "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 w3mPath :: FilePath
w3mPath) path :: 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 (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Cleanup) -> FilePath -> Cleanup
forall a b. (a -> b) -> a -> b
$
        "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 (x :: Int
x, y :: Int
y, w :: Int
w, h :: Int
h) = (Int, Int) -> (Int, Int) -> (Int, Int, Int, Int)
fit (Int, Int)
tsize (Int, Int)
isize
        command :: FilePath
command =
            "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 -> 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 -> 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 -> 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
path FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ "\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 (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
$
        "6;" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate ";" ((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 (tw :: Int
tw, th :: Int
th) (iw0 :: Int
iw0, ih0 :: 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` 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` 2 in

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


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