{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Graphics.Blank.Types.Cursor where import Data.Monoid import Data.String (IsString(..)) import qualified Data.Text as TS (Text) import Data.Text (pack) import Graphics.Blank.JavaScript import Graphics.Blank.Parser (stringCI, unlift) import Prelude.Compat import Text.ParserCombinators.ReadP (ReadP, (<++), between, char, choice, munch, skipSpaces) import Text.ParserCombinators.ReadPrec (lift) import Text.Read (Read(..), readListPrecDefault) import TextShow -- | A data type that can represent a browser cursor. class CanvasCursor a where -- | Convert a value into a JavaScript string representing a cursor value. jsCanvasCursor :: a -> Builder instance CanvasCursor TS.Text where jsCanvasCursor = jsText instance CanvasCursor Cursor where jsCanvasCursor = jsCursor -- | Specified the mouse cursor's appearance in a web browser. -- -- Images by the Mozilla Developer Network are licensed under -- . data Cursor = Auto -- ^ The browser determines the cursor to display based on the -- current context. | Default -- ^ <> | None -- ^ No cursor is rendered. | ContextMenu -- ^ <> | Help -- ^ <> | Pointer -- ^ <> | Progress -- ^ <> | Wait -- ^ <> | Cell -- ^ <> | Crosshair -- ^ <> | Text -- ^ <> | VerticalText -- ^ <> | Alias -- ^ <> | Copy -- ^ <> | Move -- ^ <> | NoDrop -- ^ <> | NotAllowed -- ^ <> | AllScroll -- ^ <> | ColResize -- ^ <> | RowResize -- ^ <> | NResize -- ^ <> | EResize -- ^ <> | SResize -- ^ <> | WResize -- ^ <> | NEResize -- ^ <> | NWResize -- ^ <> | SEResize -- ^ <> | SWResize -- ^ <> | EWResize -- ^ <> | NSResize -- ^ <> | NESWResize -- ^ <> | NWSEResize -- ^ <> | ZoomIn -- ^ <> | ZoomOut -- ^ <> | Grab -- ^ <> | Grabbing -- ^ <> | URL TS.Text Cursor -- ^ An image from a URL. Must be followed by another 'Cursor'. deriving (Eq, Ord) instance IsString Cursor where fromString = read instance JSArg Cursor where showbJS = jsCursor jsCursor :: Cursor -> Builder jsCursor = jsLiteralBuilder . showb instance Read Cursor where readPrec = lift $ do skipSpaces choice [ Auto <$ stringCI "auto" , Default <$ stringCI "default" , None <$ stringCI "none" , ContextMenu <$ stringCI "context-menu" , Help <$ stringCI "help" , Pointer <$ stringCI "pointer" , Progress <$ stringCI "progress" , Wait <$ stringCI "wait" , Cell <$ stringCI "cell" , Crosshair <$ stringCI "crosshair" , Text <$ stringCI "text" , VerticalText <$ stringCI "vertical-text" , Alias <$ stringCI "alias" , Copy <$ stringCI "copy" , Move <$ stringCI "move" , NoDrop <$ stringCI "no-drop" , NotAllowed <$ stringCI "not-allowed" , AllScroll <$ stringCI "all-scroll" , ColResize <$ stringCI "col-resize" , RowResize <$ stringCI "row-resize" , NResize <$ stringCI "n-resize" , EResize <$ stringCI "e-resize" , SResize <$ stringCI "s-resize" , WResize <$ stringCI "w-resize" , NEResize <$ stringCI "ne-resize" , NWResize <$ stringCI "nw-resize" , SEResize <$ stringCI "se-resize" , SWResize <$ stringCI "sw-resize" , EWResize <$ stringCI "ew-resize" , NSResize <$ stringCI "ns-resize" , NESWResize <$ stringCI "nesw-resize" , NWSEResize <$ stringCI "nwse-resize" , ZoomIn <$ stringCI "zoom-in" , ZoomOut <$ stringCI "zoom-out" , Grab <$ stringCI "grab" , Grabbing <$ stringCI "grabbing" , do _ <- stringCI "url(" let quoted quote = between (char quote) (char quote) url' <- quoted '"' (readURL $ Just '"') <++ quoted '\'' (readURL $ Just '\'') <++ readURL Nothing _ <- char ')' skipSpaces _ <- char ',' URL url' <$> unlift readPrec ] readListPrec = readListPrecDefault readURL :: Maybe Char -> ReadP TS.Text readURL mQuote = do url' <- case mQuote of Just quote -> munch (/= quote) Nothing -> munch (/= ')') return $ pack url' instance Show Cursor where showsPrec p = showsPrec p . FromTextShow instance TextShow Cursor where showb Auto = "auto" showb Default = "default" showb None = "none" showb ContextMenu = "context-menu" showb Help = "help" showb Pointer = "pointer" showb Progress = "progress" showb Wait = "wait" showb Cell = "cell" showb Crosshair = "crosshair" showb Text = "text" showb VerticalText = "vertical-text" showb Alias = "alias" showb Copy = "copy" showb Move = "move" showb NoDrop = "no-drop" showb NotAllowed = "not-allowed" showb AllScroll = "all-scroll" showb ColResize = "col-resize" showb RowResize = "row-resize" showb NResize = "n-resize" showb EResize = "e-resize" showb SResize = "s-resize" showb WResize = "w-resize" showb NEResize = "ne-resize" showb NWResize = "nw-resize" showb SEResize = "se-resize" showb SWResize = "sw-resize" showb EWResize = "ew-resize" showb NSResize = "ns-resize" showb NESWResize = "nesw-resize" showb NWSEResize = "nwse-resize" showb ZoomIn = "zoom-in" showb ZoomOut = "zoom-out" showb Grab = "grab" showb Grabbing = "grabbing" showb (URL url' cur) = "url(" <> jsLiteralBuilder (fromText url') <> "), " <> showb cur -- | Shorthand for 'Auto'. auto :: Cursor auto = Auto -- | Shorthand for 'Default', with an underscore to distinguish it from the -- Haskell keyword @default@. default_ :: Cursor default_ = Default -- | Shorthand for 'None'. none :: Cursor none = None -- | Shorthand for 'ContextMenu'. contextMenu :: Cursor contextMenu = ContextMenu -- | Shorthand for 'Help'. help :: Cursor help = Help -- | Shorthand for 'Pointer'. pointer :: Cursor pointer = Pointer -- | Shorthand for 'Progress'. progress :: Cursor progress = Progress -- | Shorthand for 'Wait'. wait :: Cursor wait = Wait -- | Shorthand for 'Cell'. cell :: Cursor cell = Cell -- | Shorthand for 'Crosshair'. crosshair :: Cursor crosshair = Crosshair -- | Shorthand for 'Text'. text :: Cursor text = Text -- | Shorthand for 'VerticalText'. verticalText :: Cursor verticalText = VerticalText -- | Shorthand for 'Alias'. alias :: Cursor alias = Alias -- | Shorthand for 'Copy'. copy :: Cursor copy = Copy -- | Shorthand for 'Move'. move :: Cursor move = Move -- | Shorthand for 'NoDrop'. noDrop :: Cursor noDrop = NoDrop -- | Shorthand for 'NotAllowed'. notAllowed :: Cursor notAllowed = NotAllowed -- | Shorthand for 'AllScroll'. allScroll :: Cursor allScroll = AllScroll -- | Shorthand for 'ColResize'. colResize :: Cursor colResize = ColResize -- | Shorthand for 'RowResize'. rowResize :: Cursor rowResize = RowResize -- | Shorthand for 'NResize'. nResize :: Cursor nResize = NResize -- | Shorthand for 'EResize'. eResize :: Cursor eResize = EResize -- | Shorthand for 'SResize'. sResize :: Cursor sResize = SResize -- | Shorthand for 'WResize'. wResize :: Cursor wResize = WResize -- | Shorthand for 'NEResize'. neResize :: Cursor neResize = NEResize -- | Shorthand for 'NWResize'. nwResize :: Cursor nwResize = NWResize -- | Shorthand for 'SEResize'. seResize :: Cursor seResize = SEResize -- | Shorthand for 'SWResize'. swResize :: Cursor swResize = SWResize -- | Shorthand for 'EWResize'. ewResize :: Cursor ewResize = ewResize -- | Shorthand for 'NSResize'. nsResize :: Cursor nsResize = NSResize -- | Shorthand for 'NESWResize'. neswResize :: Cursor neswResize = NESWResize -- | Shorthand for 'NWSEResize'. nwseResize :: Cursor nwseResize = NWSEResize -- | Shorthand for 'ZoomIn'. zoomIn :: Cursor zoomIn = ZoomIn -- | Shorthand for 'ZoomOut'. zoomOut :: Cursor zoomOut = ZoomOut -- | Shorthand for 'Grab'. grab :: Cursor grab = Grab -- | Shorthand for 'Grabbing'. grabbing :: Cursor grabbing = Grabbing -- | Shorthand for 'URL'. url :: TS.Text -> Cursor -> Cursor url = URL