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-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
|
|
|
|
|
|
|
|
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-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-01-31 13:47:18 +00:00
|
|
|
magic <- magicOpen [MagicMime]
|
|
|
|
magicLoadDefault magic
|
|
|
|
mime <- head <$> splitOn ";" <$> magicFile magic (T.unpack $ optFile opts)
|
|
|
|
-- when (mime /= "application/pdf") $ do
|
|
|
|
-- verb opts ("Not a PDF file: " ++ T.unpack (optFile opts))
|
|
|
|
-- exitFailure
|
2019-01-29 22:55:45 +00:00
|
|
|
SDL.initializeAll
|
|
|
|
SDL.screenSaverEnabled SDL.$= False
|
|
|
|
disps <- SDL.getDisplays
|
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-01-30 05:08:38 +00:00
|
|
|
-- set Render quality
|
2019-01-30 22:10:00 +00:00
|
|
|
SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
|
2019-01-31 21:00:29 +00:00
|
|
|
uncurry SDL.setHint =<< (,)
|
2019-02-01 04:42:28 +00:00
|
|
|
<$> newCString "SDL_VIDEO_MINIMIZE_ON_FOCUS_LOSS"
|
2019-01-31 21:00:29 +00:00
|
|
|
<*> newCString "0"
|
2019-01-30 05:08:38 +00:00
|
|
|
-- check render quality
|
|
|
|
renderQuality <- SDL.get SDL.HintRenderScaleQuality
|
2019-01-30 22:10:00 +00:00
|
|
|
when (renderQuality /= SDL.ScaleLinear) $
|
2019-01-30 05:08:38 +00:00
|
|
|
putErrLn "Linear texture filtering not enabled!"
|
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
|
|
|
|
void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
|
2019-01-31 13:47:18 +00:00
|
|
|
verb opts "Creating OpenGL context(s)"
|
2019-02-02 21:45:57 +00:00
|
|
|
context <- (SDL.glCreateContext . snd) (head wins)
|
2019-01-31 21:00:29 +00:00
|
|
|
-- verb opts "Creating NanoVG context"
|
|
|
|
-- _ <- glewInit
|
|
|
|
-- nano <- NVG.createGL3 (S.fromList [NVG.Antialias, NVG.StencilStrokes])
|
2019-02-02 21:45:57 +00:00
|
|
|
verb opts "Initializing rendering pipeline"
|
|
|
|
glInits <- mapM (initVAO . fst) wins
|
|
|
|
vebo <- initGL
|
|
|
|
programs <- mapM (\(ident, _) -> do
|
|
|
|
ret <- GU.simpleShaderProgramBS vertexShader (fragmentShader ident)
|
|
|
|
return (ident, ret)
|
2019-01-31 15:01:01 +00:00
|
|
|
)
|
2019-02-02 21:45:57 +00:00
|
|
|
wins
|
|
|
|
verb opts "Initializing state"
|
|
|
|
time <- getCurrentTime
|
|
|
|
state <- newMVar (
|
|
|
|
State
|
|
|
|
1
|
|
|
|
(last $ map fst wins)
|
|
|
|
time
|
|
|
|
glInits
|
|
|
|
programs
|
|
|
|
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-01-31 15:09:01 +00:00
|
|
|
mapM_ (eventHandler run) =<< 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
|
2019-01-31 13:47:18 +00:00
|
|
|
GL.flush
|
2019-02-02 21:45:57 +00:00
|
|
|
SDL.glSwapWindow window
|
|
|
|
) wins
|
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
|