threepenny-gui-contextmenu (empty) → 0.1.0.0
raw patch · 8 files changed
+293/−0 lines, 8 filesdep +basedep +threepenny-guidep +threepenny-gui-contextmenusetup-changed
Dependencies added: base, threepenny-gui, threepenny-gui-contextmenu
Files
- LICENSE +30/−0
- README.md +5/−0
- Setup.hs +2/−0
- app/Main.hs +41/−0
- src/ContextMenu.hs +111/−0
- src/ContextMenu/Style.hs +29/−0
- src/ContextMenu/Util.hs +39/−0
- threepenny-gui-contextmenu.cabal +36/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -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)]+
+ src/ContextMenu.hs view
@@ -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)
+ src/ContextMenu/Style.hs view
@@ -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")+ ]
+ src/ContextMenu/Util.hs view
@@ -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
@@ -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