ibis/src/Main.hs

162 lines
4.2 KiB
Haskell
Raw Permalink Normal View History

2019-01-31 13:47:18 +00:00
{-# LANGUAGE BangPatterns #-}
2019-01-29 22:55:45 +00:00
module Main where
import qualified SDL
2019-01-30 22:10:00 +00:00
import qualified SDL.Raw.Video as SDL (glSetAttribute)
import qualified SDL.Raw.Enum as SDL
2019-01-31 21:00:29 +00:00
import qualified SDL.Raw.Basic as SDL
2019-01-29 22:55:45 +00:00
2019-01-30 23:11:39 +00:00
import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
2019-02-02 21:45:57 +00:00
import qualified Graphics.GLUtil as GU
2019-02-08 15:10:52 +00:00
import Graphics.UI.Gtk.Poppler.Page
import Graphics.UI.Gtk.Poppler.Document
2019-01-31 21:00:29 +00:00
-- import qualified NanoVG as NVG
2019-01-31 13:47:18 +00:00
2019-01-29 22:55:45 +00:00
import Linear
import Options.Applicative
2019-01-30 05:08:38 +00:00
import Control.Monad
2019-01-30 23:11:39 +00:00
import Control.Monad.Loops
2019-02-07 14:45:45 +00:00
import Control.Concurrent (threadDelay)
2019-01-30 23:11:39 +00:00
import Control.Concurrent.MVar
2019-01-30 05:08:38 +00:00
2019-01-30 22:10:00 +00:00
import qualified Data.Text as T
2019-01-31 13:47:18 +00:00
import qualified Data.Set as S
import Data.List.Split (splitOn)
import Data.Maybe
2019-01-31 15:01:01 +00:00
import Data.Time.Clock
2019-02-07 14:45:45 +00:00
import Data.Word (Word32(..))
2019-01-31 13:47:18 +00:00
import System.Exit (exitFailure)
2019-01-31 21:00:29 +00:00
import Foreign.C.String
2019-01-31 13:47:18 +00:00
import Magic
2019-01-29 22:55:45 +00:00
-- internal imports
2019-01-31 15:01:01 +00:00
import Events
2019-02-02 21:45:57 +00:00
import Draw
2019-01-29 22:55:45 +00:00
import Util
2019-01-30 22:10:00 +00:00
import Types
2019-01-29 22:55:45 +00:00
main :: IO ()
main = do
opts <- execParser $ info (options <**> helper)
( fullDesc
<> progDesc "A simple PDF presenter written in Haskell using poppler and SDL2"
)
2019-02-08 15:10:52 +00:00
checkMagic opts
disps <- sdlInit
2019-01-31 13:47:18 +00:00
verb opts ("Number of displays detected: " ++ show (length disps))
verb opts ("Passed command line options: " ++ show opts)
2019-02-08 15:10:52 +00:00
mdoc <- documentNewFromFile (T.unpack $ "file://" <> optFile opts) Nothing
document <- case mdoc of
Just d -> return d
Nothing -> do
putErrLn ("Could not open file: " ++ T.unpack (optFile opts))
exitFailure
aspect <- fmap (\(w, h) -> w / h) (pageGetSize =<< documentGetPage document 0)
npag <- documentGetNPages document
2019-01-31 13:47:18 +00:00
verb opts "Creating window configuration(s)"
let !confs = map makeWindowConfig disps
verb opts "Creating window(s)"
2019-01-30 22:10:00 +00:00
wins <- zip ([0 .. ] :: [Word]) <$> mapM (uncurry SDL.createWindow) (
zip
2019-01-31 13:47:18 +00:00
( if length disps == 1
then
[ "Ibis - " <> optFile opts ]
else
[ "Ibis - " <> optFile opts <> " - Notes"
, "Ibis - " <> optFile opts
]
)
confs
2019-01-30 22:10:00 +00:00
)
when (optFullscreen opts) $
mapM_ (flip SDL.setWindowMode SDL.FullscreenDesktop . snd) wins
2019-01-31 13:47:18 +00:00
verb opts "Creating OpenGL context(s)"
2019-02-02 23:57:52 +00:00
context <- (SDL.glCreateContext . snd) (last wins)
2019-02-02 21:45:57 +00:00
verb opts "Initializing rendering pipeline"
2019-02-02 23:57:52 +00:00
initVAO
2019-02-02 21:45:57 +00:00
vebo <- initGL
2019-02-03 01:08:37 +00:00
program <- GU.simpleShaderProgramBS vertexShader fragmentShader
2019-02-02 21:45:57 +00:00
verb opts "Initializing state"
2019-02-07 14:45:45 +00:00
time <- SDL.ticks
2019-02-02 21:45:57 +00:00
state <- newMVar (
State
2019-02-08 15:10:52 +00:00
0
(fromIntegral $ npag - 1)
aspect
2019-02-04 19:33:45 +00:00
(optFile opts)
2019-02-02 21:45:57 +00:00
(last $ map fst wins)
time
2019-02-07 14:45:45 +00:00
time
2019-02-02 23:57:52 +00:00
wins
2019-02-03 01:08:37 +00:00
program
2019-02-02 21:45:57 +00:00
vebo
)
2019-01-31 15:01:01 +00:00
verb opts "Displaying window(s)"
2019-01-30 22:10:00 +00:00
mapM_ (SDL.showWindow . snd) wins
2019-01-31 13:47:18 +00:00
verb opts "Entering Loop"
2019-01-30 23:11:39 +00:00
run <- newMVar True
whileM_ (readMVar run) (do
2019-02-02 21:45:57 +00:00
mapM_ (\(ident, window) -> do
SDL.glMakeCurrent window context
2019-02-03 01:08:37 +00:00
mapM_ (eventHandler run state) =<< SDL.pollEvents
2019-01-31 13:47:18 +00:00
GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
2019-02-02 21:45:57 +00:00
draw state ident
SDL.glSwapWindow window
) wins
2019-02-07 14:45:45 +00:00
st <- readMVar state
now <- SDL.ticks
-- let dt = now - (stLastTime st)
-- verb opts ("dt: " ++ show dt)
-- threadDelay (fromIntegral $ (max 0 ((1000 `div` 30) - dt)))
modifyMVar_ state (\st -> return st { stLastTime = now })
2019-01-30 23:11:39 +00:00
)
2019-02-02 21:45:57 +00:00
verb opts "Deleting context"
SDL.glDeleteContext context
2019-01-31 13:47:18 +00:00
verb opts "Destroying window(s)"
2019-01-30 23:11:39 +00:00
mapM_ (SDL.destroyWindow . snd) wins
2019-02-08 15:10:52 +00:00
checkMagic :: Options -> IO ()
checkMagic opts = do
magic <- magicOpen [MagicMime]
magicLoadDefault magic
mime <- head <$> splitOn ";" <$> magicFile magic (T.unpack $ optFile opts)
when (mime /= "application/pdf") $ do
putErrLn ("Not a PDF file: " ++ T.unpack (optFile opts))
exitFailure
sdlInit :: IO [SDL.Display]
sdlInit = do
SDL.initializeAll
SDL.screenSaverEnabled SDL.$= False
SDL.cursorVisible SDL.$= False
disps <- SDL.getDisplays
-- set Render quality
SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
-- check render quality
renderQuality <- SDL.get SDL.HintRenderScaleQuality
when (renderQuality /= SDL.ScaleLinear) $
putErrLn "Linear texture filtering not enabled!"
uncurry SDL.setHint =<< (,)
<$> newCString "SDL_VIDEO_MINIMIZE_ON_FOCUS_LOSS"
<*> newCString "0"
void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
return disps