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


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


--------------------------------------------------------------------------------
backend :: Internal.Backend
backend :: Backend
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 forall a b. (a -> b) -> a -> b
$ case Config Config
config of
        Internal.Explicit Config
c -> Config -> Maybe FilePath
cPath Config
c
        Config Config
_                   -> forall a. Maybe a
Nothing

    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
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 = \case
    -- Use the path specified by the user.
    Just FilePath
path -> do
        Bool
exe <- FilePath -> IO Bool
isExecutable FilePath
path
        if Bool
exe
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FilePath -> W3m
W3m FilePath
path
            else forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$
                    FilePath -> BackendNotSupported
Internal.BackendNotSupported forall a b. (a -> b) -> a -> b
$ FilePath
path 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 <- forall e a. Exception e => IO a -> IO (Either e a)
try 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)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure W3m
path          -- Found it.
            Left IOException
_ -> FilePath -> W3m
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 []       = forall e a. Exception e => e -> IO a
throwIO 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 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
            forall (m :: * -> *) a. Monad m => a -> m a
return (Permissions -> Bool
Directory.executable Permissions
perms)
        else
            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 <- forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
ws, Just Int
h <- forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
hs ->
        forall (m :: * -> *) a. Monad m => a -> m a
return (Int
w, Int
h)
    [FilePath]
_  -> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (Int, Int)
wh
        Maybe (Int, Int)
_       -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$
            FilePath
"Patat.Images.W3m.getTerminalSize: " 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;" forall a. [a] -> [a] -> [a]
++ FilePath
path forall a. [a] -> [a] -> [a]
++ FilePath
"\n")
    case FilePath -> Maybe (Int, Int)
parseWidthHeight FilePath
output of
        Just (Int, Int)
wh -> forall (m :: * -> *) a. Monad m => a -> m a
return (Int, Int)
wh
        Maybe (Int, Int)
_       -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$
            FilePath
"Patat.Images.W3m.getImageSize: " forall a. [a] -> [a] -> [a]
++
            FilePath
"Could not parse image size using `w3mimgdisplay` for " 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$
        FilePath
"Patat.Images.W3m.drawImage: file does not exist: " 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;" forall a. [a] -> [a] -> [a]
++
            forall a. Show a => a -> FilePath
show Int
x forall a. [a] -> [a] -> [a]
++ FilePath
";" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
y forall a. [a] -> [a] -> [a]
++ FilePath
";" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
w forall a. [a] -> [a] -> [a]
++ FilePath
";" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
h forall a. [a] -> [a] -> [a]
++
            FilePath
";;;;;" forall a. [a] -> [a] -> [a]
++ FilePath
path 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.
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath -> IO FilePath
Process.readProcess FilePath
w3mPath [] forall a b. (a -> b) -> a -> b
$
        FilePath
"6;" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate FilePath
";" (forall a b. (a -> b) -> [a] -> [b]
map 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 forall a. Ord a => a -> a -> Bool
> Int
tw then Int
tw else Int
iw0
            ih1 :: Int
ih1 = if Int
iw0 forall a. Ord a => a -> a -> Bool
> Int
tw then ((Int
ih0 forall a. Num a => a -> a -> a
* Int
tw) forall a. Integral a => a -> a -> a
`div` Int
iw0) else Int
ih0

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

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

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