diff --git a/monomer.cabal b/monomer.cabal index 6a64c734..d577c690 100644 --- a/monomer.cabal +++ b/monomer.cabal @@ -179,6 +179,7 @@ library , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , filepath ==1.4.* , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , http-client >=0.6 && <0.9 @@ -225,6 +226,7 @@ executable books , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , filepath ==1.4.* , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , http-client >=0.6 && <0.9 @@ -268,6 +270,7 @@ executable dev-test-app , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , filepath ==1.4.* , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , http-client >=0.6 && <0.9 @@ -310,6 +313,7 @@ executable generative , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , filepath ==1.4.* , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , http-client >=0.6 && <0.9 @@ -355,6 +359,7 @@ executable opengl , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , filepath ==1.4.* , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , http-client >=0.6 && <0.9 @@ -402,6 +407,7 @@ executable ticker , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , filepath ==1.4.* , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , http-client >=0.6 && <0.9 @@ -448,6 +454,7 @@ executable todo , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , filepath ==1.4.* , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , http-client >=0.6 && <0.9 @@ -499,6 +506,7 @@ executable tutorial , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , filepath ==1.4.* , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , http-client >=0.6 && <0.9 @@ -597,6 +605,7 @@ test-suite monomer-test , data-default >=0.5 && <0.8 , exceptions ==0.10.* , extra >=1.6 && <1.9 + , filepath ==1.4.* , foreign-store >=0.2 && <1.0 , formatting >=6.0 && <8.0 , hspec >=2.4 && <3.0 diff --git a/package.yaml b/package.yaml index 1c829416..c43bc7b0 100644 --- a/package.yaml +++ b/package.yaml @@ -52,6 +52,8 @@ dependencies: - transformers >= 0.5 && < 0.7 - vector >= 0.12 && < 0.14 - wreq >= 0.5.2 && < 0.6 +# - filepath >= 1.4.100.1 && < 1.5 + - filepath >= 1.4 && < 1.5 flags: examples: diff --git a/src/Monomer/Event/Core.hs b/src/Monomer/Event/Core.hs index 7f63fa4d..1681af82 100644 --- a/src/Monomer/Event/Core.hs +++ b/src/Monomer/Event/Core.hs @@ -15,12 +15,20 @@ module Monomer.Event.Core ( translateEvent ) where -import Control.Applicative ((<|>)) +--import Control.Applicative ((<|>)) +import Control.Monad (forM) import Data.Maybe (catMaybes) import Data.Text (Text) import qualified SDL +-- 'OsPath' is not part of current LTS snapshot, yet. +--import System.IO (utf8, utf16le, EncodingException(..)) +--import System.OsPath +--import System.OsString.Internal (encodeWith) +import System.FilePath +import Foreign.C.String + import Monomer.Common import Monomer.Event.Types @@ -36,6 +44,7 @@ isActionEvent SDL.MouseWheelEvent{} = True isActionEvent SDL.KeyboardEvent{} = True isActionEvent SDL.TextEditingEvent{} = True isActionEvent SDL.TextInputEvent{} = True +isActionEvent SDL.DropEvent{} = True isActionEvent _ = False -- | Configuration options for converting from an SDL event to a 'SystemEvent'. @@ -47,22 +56,30 @@ data ConvertEventsCfg = ConvertEventsCfg { _cecInvertWheelY :: Bool -- ^ Whether wheel/trackpad y direction should be inverted. } deriving (Eq, Show) --- | Converts SDL events to Monomer's SystemEvent +-- | Converts SDL events to Monomer's SystemEvent. +-- IO necessary for marshalling (i.e. peekCString) convertEvents :: ConvertEventsCfg -- ^ Settings for event conversion. -> Point -- ^ Mouse position. -> [SDL.EventPayload] -- ^ List of SDL events. - -> [SystemEvent] -- ^ List of Monomer events. -convertEvents cfg mousePos events = catMaybes convertedEvents where - ConvertEventsCfg os dpr epr invertX invertY = cfg - convertedEvents = fmap convertEvent events - convertEvent evt = - mouseMoveEvent mousePos evt - <|> mouseClick mousePos evt - <|> mouseWheelEvent cfg mousePos evt - <|> mouseMoveLeave mousePos evt - <|> keyboardEvent evt - <|> textEvent evt + -> IO [SystemEvent] -- ^ List of Monomer events. +convertEvents cfg mousePos events = + fmap catMaybes $ forM events $ eventHandler [ mouseMove, mouseClk, mouseWheel, mouseLeave, keyboard, text, fileDrop ] + where + ConvertEventsCfg os dpr epr invertX invertY = cfg + mouseMove = \e -> return $ mouseMoveEvent mousePos e + mouseClk = \e -> return $ mouseClick mousePos e + mouseWheel = \e -> return $ mouseWheelEvent cfg mousePos e + mouseLeave = \e -> return $ mouseMoveLeave mousePos e + keyboard = \e -> return $ keyboardEvent e + text = \e -> return $ textEvent e + fileDrop = \e -> fileDropEvent mousePos e + + eventHandler (f:fs) = \e -> f e >>= \maybeSE -> case maybeSE of + Just se -> return $ Just se + Nothing -> eventHandler fs e + eventHandler [] = \e -> return Nothing + -- | Adds a given offset to mouse related SystemEvents. translateEvent @@ -141,6 +158,19 @@ textEvent (SDL.TextInputEvent input) = Just textInput where textInput = TextInput (SDL.textInputEventText input) textEvent _ = Nothing +-- TODO: 'OsPath' instead of 'FilePath' should be used, but is currently not part of the newest LTS snapshot +--fileDropEvent :: Point -> SDL.EventPayload -> IO (Maybe SystemEvent) +--fileDropEvent _ (SDL.DropEvent (SDL.DropEventData cstr)) = +-- peekCString cstr >>= \str -> case encodeWith utf8 utf16le str of +-- Right osstr -> return $ Just (FileDrop osstr) +-- _ -> return Nothing +fileDropEvent :: Point -> SDL.EventPayload -> IO (Maybe SystemEvent) +fileDropEvent _ (SDL.DropEvent (SDL.DropEventData cstr)) = do + str <- peekCString cstr -- the filepath 'cstr' must be an utf8 string when we compare to the SDL example https://wiki.libsdl.org/SDL2/SDL_DropEvent + putStrLn $ "FileDrop: " ++ str + return $ Just (FileDrop str) +fileDropEvent _ _ = return Nothing + convertKeyModifier :: SDL.KeyModifier -> KeyMod convertKeyModifier keyMod = KeyMod { _kmLeftShift = SDL.keyModifierLeftShift keyMod, diff --git a/src/Monomer/Event/Types.hs b/src/Monomer/Event/Types.hs index 8ae9cbf4..2c6b8416 100644 --- a/src/Monomer/Event/Types.hs +++ b/src/Monomer/Event/Types.hs @@ -17,6 +17,8 @@ import Data.Default import Data.Text (Text) import Data.Typeable (Typeable, cast, typeOf) import Data.Map.Strict (Map) +--import System.OsPath (OsPath) +import System.FilePath (FilePath) import qualified Data.Map.Strict as M @@ -117,6 +119,9 @@ data SystemEvent -- | A drag action was active and the main button was released inside the -- current viewport. | Drop Point Path WidgetDragMsg + -- | File dragged and dropped into window. + -- | FileDrop OsPath -- OsPath should be used but is currently not part of the newest LTS snapshot yet. for now, use old FilePath instead: + | FileDrop FilePath deriving (Eq, Show) -- | Status of input devices. diff --git a/src/Monomer/Main/Core.hs b/src/Monomer/Main/Core.hs index 7e2b46dd..b25ae36b 100644 --- a/src/Monomer/Main/Core.hs +++ b/src/Monomer/Main/Core.hs @@ -332,7 +332,7 @@ mainLoop window fontManager config loopArgs = do let invertX = fromMaybe False (_apcInvertWheelX config) let invertY = fromMaybe False (_apcInvertWheelY config) let convertCfg = ConvertEventsCfg _mlOS dpr epr invertX invertY - let baseSystemEvents = convertEvents convertCfg mousePos eventsPayload + baseSystemEvents <- liftIO $ convertEvents convertCfg mousePos eventsPayload -- when newSecond $ -- liftIO . putStrLnErr $ "Frames: " ++ show _mlFrameCount diff --git a/src/Monomer/Main/Handlers.hs b/src/Monomer/Main/Handlers.hs index 657b17a9..08147831 100644 --- a/src/Monomer/Main/Handlers.hs +++ b/src/Monomer/Main/Handlers.hs @@ -910,6 +910,8 @@ getTargetPath wenv root pressed overlay target event = case event of TextInput _ -> pathEvent target -- Clipboard Clipboard _ -> pathEvent target + -- FileDrop + FileDrop _ -> pathEvent target -- Mouse/touch ButtonAction point _ BtnPressed _ -> pointEvent point ButtonAction _ _ BtnReleased _ -> pathEvent target