diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# Threepenny-gui Context Menu + +Write simple nested context menus for threepenny-gui. + +Menu items can either be UI actions to run or a nested menu. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,41 @@ +module Main where + +import qualified ContextMenu as Menu +import Control.Monad +import qualified Graphics.UI.Threepenny as UI +import Graphics.UI.Threepenny.Core + +-- | Runs the example. +main :: IO () +main = startGUI defaultConfig example + +-- | Example use of threepenny contextmenu. +example :: Window -> UI () +example window = void $ do + body <- getBody window + button <- UI.button # set UI.text "right-click me!" + Menu.contextMenu (menuItems button) body + element body #+ [element button] + +-- | Menu items to change an element red or blue. +menuItems :: Element -> [Menu.MenuItem Element] +menuItems el = [ + Menu.actionMenuItem "red" [colour el "red" ], + Menu.actionMenuItem "blue" [colour el "blue"], + Menu.nestedMenuItem "more" [ + Menu.actionMenuItem "green" [colour el "green"], + Menu.nestedMenuItem "even more" [ + Menu.actionMenuItem "red" [colour el "red" ], + Menu.actionMenuItem "blue" [colour el "blue"] + ], + Menu.nestedMenuItem "even more" [ + Menu.actionMenuItem "red" [colour el "red" ], + Menu.actionMenuItem "blue" [colour el "blue"] + ] + ] + ] + +-- | Sets an element's colour to the given string. +colour :: Element -> String -> UI Element +colour el str = element el # set style [("color", str)] + diff --git a/src/ContextMenu.hs b/src/ContextMenu.hs new file mode 100644 --- /dev/null +++ b/src/ContextMenu.hs @@ -0,0 +1,111 @@ +-- This module could potentially be rewritten and heavily simplified once the +-- custom context menu spec in HTML 5.1 is adopted by all major browsers. At +-- time of writing the spec is only a recommendation and only implemented by +-- Mozilla Firefox. + +module ContextMenu where + +import ContextMenu.Style +import ContextMenu.Util +import Control.Monad (when) +import qualified Graphics.UI.Threepenny as UI +import Graphics.UI.Threepenny.Core + +-- |A menu item is some text to be displayed and either UI actions to execute or +-- a nested menu. +data MenuItem a = MenuItem { mIText :: String, mIValue :: MenuItemValue a } +data MenuItemValue a = MenuItemActions [Action] | NestedMenu [MenuItem a] + +-- |Constructor for a menu item that contains UI actions to execute. +actionMenuItem :: String -> [Action] -> MenuItem a +actionMenuItem text actions = + MenuItem { mIText = text, mIValue = MenuItemActions actions } + +-- |Constructor for a menu item that contains a nested menu. +nestedMenuItem :: String -> [MenuItem a] -> MenuItem a +nestedMenuItem text nested = + MenuItem { mIText = text ++ " ›", mIValue = NestedMenu nested } + +-- |Creates a custom context menu and attaches it to a given element. Prevents +-- the default context menu from occuring. +contextMenu :: [MenuItem a] -> Element -> UI () +contextMenu items sourceEl = do + contextMenuEls <- contextMenu' items sourceEl + element sourceEl #+ contextMenuEls + preventDefaultContextMenu sourceEl + +-- |Attaches a custom context menu to an element. +contextMenu' :: [MenuItem a] -> Element -> UI [Action] +contextMenu' items sourceEl = do + rmTargetEl <- UI.div # set style rmTargetStyle + let closeRmTarget = dimensions "0" "0" rmTargetEl + (menuEl, closeMenu, closeNestedMenus) <- newMenu [closeRmTarget] items + -- Display menu on a contextmenu event. + on UI.contextmenu sourceEl $ \(x, y) -> + displayAt x y menuEl >> dimensions "100vw" "100vh" rmTargetEl + -- Hide everything on rmTarget click. + on UI.mousedown rmTargetEl $ const $ + closeRmTarget >> closeMenu >> sequence closeNestedMenus + -- Hide nested menus on hover over rmTarget. + on UI.hover rmTargetEl $ const $ sequence closeNestedMenus + return [element rmTargetEl, element menuEl] + +-- |Returns a menu element, an action to close the menu and actions to close any +-- nested menus. +newMenu :: [Action] -> [MenuItem a] -> UI (Element, Action, [Action]) +newMenu closeParents menuItems = do + menuEl <- UI.li # set style menuStyle + let closeMenu = display "none" menuEl + -- Menu items as elements and respective list of actions to close nested + -- menus. :: UI [(Element, [Action])] + menuItemEls <- mapM (menuItem $ closeParents ++ [closeMenu]) menuItems + element menuEl #+ map (element . fst) menuItemEls + -- On hover over a menu item we want close any nested menus from + -- *other* menu items. + let closeOtherMenusOnHover ((el1, _), i1) xs = + on UI.hover el1 $ const $ do + let closeIfNotSelf ((_, closeEl2), i2) = + when (i1 /= i2) (sequence_ closeEl2) + mapM closeIfNotSelf xs + mapPairsWithIndex menuItemEls closeOtherMenusOnHover + return (menuEl, closeMenu, concat (map snd menuItemEls)) + +-- |Returns a menu item element and actions to open and close it. +menuItem :: [Action] -> MenuItem a -> UI (Element, [Action]) +menuItem closeAbove (MenuItem text value) = do + menuItemEl <- UI.li # set UI.text text # set style menuItemStyle + highlightWhileHover menuItemEl + case value of + MenuItemActions actions -> do + -- On click execute the actions and close the entire menu. + on UI.click menuItemEl $ const $ do + sequence_ $ closeAbove ++ actions + liftIO $ putStrLn "event clicked" + return (menuItemEl, []) + NestedMenu nestedMenuItems -> do + (nestedMenuEl, closeMenu, closeNestedMenu) + <- newMenu closeAbove nestedMenuItems + -- Position a nested menu relative to this menu item. + element menuItemEl # set UI.position "relative" + element nestedMenuEl # set UI.position "absolute" # set UI.right "0px" # set UI.top "0px" + element menuItemEl #+ [element nestedMenuEl] + -- On hover display the nested menu. + on UI.hover menuItemEl $ const $ display "block" nestedMenuEl + return (menuItemEl, [closeMenu] ++ closeNestedMenu) + +-- |Highlight a given element while it is hovered over. +highlightWhileHover :: Element -> UI () +highlightWhileHover el = whileHover el + (element el # set style [("background-color", "#DEF" )]) + (element el # set style [("background-color", "inherit")]) + +-- |CSS class used to identify elements on which to prevent a default context +-- menu from opening. +preventDefaultClass = "__prevent-default-context-menu" + +-- |Prevents a default context menu opening from the given element. +preventDefaultContextMenu :: Element -> UI () +preventDefaultContextMenu el = do + element el # set UI.class_ preventDefaultClass + runFunction $ ffi "$(%1).bind('contextmenu', e => e.preventDefault())" + ("." ++ preventDefaultClass) diff --git a/src/ContextMenu/Style.hs b/src/ContextMenu/Style.hs new file mode 100644 --- /dev/null +++ b/src/ContextMenu/Style.hs @@ -0,0 +1,29 @@ +module ContextMenu.Style where + +-- |Default style for the context menu. +menuStyle = [ + ("background", "#FFF"), + ("border", "1px solid #CCC"), + ("border-radius", "3px"), + ("color", "#333"), + ("display", "none"), + ("list-style-type", "none"), + ("margin", "0"), + ("padding-left", "0"), + ("position", "absolute") + ] + +-- |Default style for any menu items. +menuItemStyle = [ + ("cursor", "pointer"), + ("padding", "8px 12px") + ] + +-- |Full-screen transparent target to close the menu. +rmTargetStyle = [ + ("height", "0"), + ("left", "0"), + ("position", "absolute"), + ("top", "0"), + ("width", "0") + ] diff --git a/src/ContextMenu/Util.hs b/src/ContextMenu/Util.hs new file mode 100644 --- /dev/null +++ b/src/ContextMenu/Util.hs @@ -0,0 +1,39 @@ +module ContextMenu.Util where + +import Data.Maybe (catMaybes) +import qualified Graphics.UI.Threepenny as UI +import Graphics.UI.Threepenny.Core + +type Action = UI Element + +-- |Sets the CSS "display: X;" on the given element. +display :: String -> Element -> UI Element +display x el = element el # set style [("display", x)] + +-- |Displays the given element at given coordinates. +displayAt :: Int -> Int -> Element -> UI Element +displayAt x y el = do + element el # set style [("left", show x ++ "px"), ("top", show y ++ "px")] + display "block" el + +-- |Sets the CSS dimensions of an element to the given values. +dimensions :: String -> String -> Element -> UI Element +dimensions w h el = element el # set style [("width", w), ("height", h)] + +-- |A little bit of gymastics to restructure the given data. +extract :: [(Element, Maybe [Action])] -> UI ([Element], [Action]) +extract tuples = return (map fst tuples, concat $ catMaybes $ map snd tuples) + +-- |Execute one action on hover and another on leave. +whileHover :: Element -> Action -> Action -> UI () +whileHover el onHover onLeave = do + on UI.hover el $ const onHover + on UI.leave el $ const onLeave + +-- |For each element in the list we apply a user defined function which takes +-- the current element and its index (a, Int), and the original list with +-- indexed elements [(a, Int)]. +mapPairsWithIndex :: [a] -> ((a, Int) -> [(a, Int)] -> UI ()) -> UI () +mapPairsWithIndex xs f = do + let indexedXs = zip xs [1..] + mapM_ (flip f indexedXs) indexedXs diff --git a/threepenny-gui-contextmenu.cabal b/threepenny-gui-contextmenu.cabal new file mode 100644 --- /dev/null +++ b/threepenny-gui-contextmenu.cabal @@ -0,0 +1,36 @@ +name: threepenny-gui-contextmenu +version: 0.1.0.0 +synopsis: Write simple nested context menus for threepenny-gui. +description: Please see README.md +homepage: https://github.com/barischj/threepenny-gui-contextmenu#readme +license: BSD3 +license-file: LICENSE +author: Jeremy Barisch-Rooney +maintainer: example@example.com +copyright: 2016 Jeremy Barisch-Rooney +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: ContextMenu + , ContextMenu.Style + , ContextMenu.Util + build-depends: base >= 4.7 && < 5, + threepenny-gui + default-language: Haskell2010 + +executable threepenny-gui-contextmenu-exe + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , threepenny-gui + , threepenny-gui-contextmenu + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/barischj/threepenny-gui-contextmenu