dialog 0.1.0.0 → 0.2.0.0

raw patch · 8 files changed

+177/−150 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• data/html/dialog.js +5/−1
• dialog.cabal +4/−1
• library/Dialog.hs +2/−1
• library/Dialog/EncodeJSON.hs +0/−3
• library/Dialog/Internal.hs +15/−107
• library/Dialog/RunDialog.hs +1/−1
• library/Dialog/RunWebkitGtk3.hs +45/−36
• library/Dialog/Shorthands.hs +105/−0

@@ -71,6 +71,10 @@   $("#end-dialog").removeClass("exception").hide(); } +function couldNotOpenBrowser(url) {+  alert("Could not open browser for URL: " + url);+}+ //------------------------------------------------------------------------------  function doThenScrollToEnd(func) {@@ -104,7 +108,7 @@   } else if (type == "picture") {     return $("<p>").append(createPicture(paragraph.source));   } else if (type == "list") {-    var tag = paragraph.style == "numbered" ? "<li>"+    var tag = paragraph.style == "numbered" ? "<ol>"             : paragraph.style == "bullet"   ? "<ul>"             : undefined;     return $(tag).append(paragraph.items.map(function(paragraphs) {

@@ -1,7 +1,7 @@ name:   dialog version:-  0.1.0.0+  0.2.0.0 synopsis:   Simple dialog-based user interfaces homepage:@@ -36,6 +36,7 @@   exposed-modules:     Dialog     Dialog.Internal+    Dialog.Shorthands     Dialog.EncodeJSON     Dialog.RunDialog     Dialog.RunWebkitGtk3@@ -53,6 +54,8 @@     open-browser   default-language:     Haskell2010+  ghc-options:+    -Wall  source-repository head   type:

@@ -42,7 +42,7 @@   color,   size,   url,-  il,+  ol,   ul,   li,   li',@@ -85,6 +85,7 @@  import Control.Monad.IO.Class (MonadIO (..)) import Dialog.Internal+import Dialog.Shorthands import Dialog.RunDialog  --------------------------------------------------------------------------------

@@ -6,8 +6,6 @@ --------------------------------------------------------------------------------  {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverloadedStrings #-}  --------------------------------------------------------------------------------@@ -25,7 +23,6 @@ --------------------------------------------------------------------------------  import Data.Monoid ((<>))-import Data.Text (Text) import Dialog.Internal import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB

@@ -7,11 +7,6 @@  {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK not-home #-}  --------------------------------------------------------------------------------@@ -22,11 +17,9 @@  import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.IO.Class (MonadIO (..))-import Data.Monoid ((<>)) import Data.String (IsString (..)) import Control.Monad (ap) import Data.Word (Word8)-import qualified Data.Text as T  -------------------------------------------------------------------------------- -- Dialog monad transformer@@ -77,7 +70,7 @@ changeEndMessage = ChangeEndMessage  ----------------------------------------------------------------------------------- Displaying messages+-- Displaying simple messages --------------------------------------------------------------------------------  -- | Displays a plain-text single-line message.@@ -93,111 +86,13 @@ askLine = AskLine  ----------------------------------------------------------------------------------- Formatted messages+-- Displaying formatted messages --------------------------------------------------------------------------------  -- | Displays a message. display :: [Paragraph] -> DialogT m () display = Display --- | Shorthand for 'TextParagraph'.-p :: FormattedText -> Paragraph-p = TextParagraph---- | Makes an unlabeled link. Shorthand for @('Link' url ('Plain' url))@.-url :: String -> FormattedText-url url = Link url (Plain url)---- | Makes a labeled link. Alias for 'Link'.-link :: String -> FormattedText -> FormattedText-link = Link---- | Shorthand for @('Picture' ('PictureFromURL' url))@.-img :: String -> Paragraph-img url = Picture (PictureFromURL url)---- | Makes a numbered list. Shorthand for @('List' 'NumberedList' items)@.-il :: [ListItem] -> Paragraph-il = List NumberedList---- | Makes a bullet list. Shorthand for @('List' 'BulletList' items)@.-ul :: [ListItem] -> Paragraph-ul = List BulletList---- | Makes a single-line list item. Shorthand for --- @('ListItem' ['TextParagraph' text])@.-li :: FormattedText -> ListItem-li richText = ListItem [TextParagraph richText]---- | Makes a list item. Shorthand for 'ListItem'.-li' :: [Paragraph] -> ListItem-li' = ListItem---- | Combines two formatted texts together.-(<+>) :: FormattedText -> FormattedText -> FormattedText-(<+>) (CompositeText a) (CompositeText b) =-  CompositeText (a ++ b)-(<+>) a (CompositeText b) =-  CompositeText (a:b)-(<+>) (CompositeText a) b =-  CompositeText (a ++ [b])-(<+>) a b =-  CompositeText [a, b]--infixr 6 <+>---- | Converts a 'String' to a 'FormattedText'. Shorthand for 'Plain'.-str :: String -> FormattedText-str = Plain---- | Makes a text bold. Shorthand for 'Bold'.-b :: FormattedText -> FormattedText-b = Bold---- | Makes a text italic. Shorthand for 'Italic'.-i :: FormattedText -> FormattedText-i = Italic---- | Makes a text underlined. Shorthand for 'Underline'.-u :: FormattedText -> FormattedText-u = Underline---- | Changes the color of a text. Alias of 'Colored'.-color :: Color -> FormattedText -> FormattedText-color = Colored---- | Changes the size of a text. Alias of 'Size'.-size :: FontSize -> FormattedText -> FormattedText-size = Size---- | Makes a table. Alias for 'Table'.-table :: [TableRow] -> Paragraph-table = Table---- | Makes a table row. Shorthand for 'TableRow'.-tr :: [TableCell] -> TableRow-tr = TableRow---- | Makes a normal table cell with a single line of text in it. Shorthand for--- @('TableCell' 'NormalCell' ['TextParagraph' text])@.-td :: FormattedText -> TableCell-td richText = TableCell NormalCell [TextParagraph richText]---- | Makes a table header cell with a single line of text in it. Shorthand for--- @('TableCell' 'HeaderCell' ['TextParagraph' text])@.-th :: FormattedText -> TableCell-th richText = TableCell HeaderCell [TextParagraph richText]---- | Makes a normal table cell. Shorthand for--- @('TableCell' 'NormalCell' paragraphs)@.-td' :: [Paragraph] -> TableCell-td' = TableCell NormalCell---- | Makes a header table cell. Shorthand for--- @('TableCell' 'HeaderCell' paragraphs)@.-th' :: [Paragraph] -> TableCell-th' = TableCell HeaderCell- -------------------------------------------------------------------------------- -- Formatted text --------------------------------------------------------------------------------@@ -224,6 +119,19 @@  instance IsString FormattedText where   fromString string = Plain string++-- | Combines two formatted texts together.+(<+>) :: FormattedText -> FormattedText -> FormattedText+(<+>) (CompositeText a) (CompositeText b) =+  CompositeText (a ++ b)+(<+>) a (CompositeText b) =+  CompositeText (a:b)+(<+>) (CompositeText a) b =+  CompositeText (a ++ [b])+(<+>) a b =+  CompositeText [a, b]++infixr 6 <+>  -------------------------------------------------------------------------------- 

@@ -21,6 +21,6 @@  -- | Opens a dialog window and runs the given dialog in it. dialog :: MonadIO m => DialogIO () -> m ()-dialog dialog = runDialogUsingWebkitGtk3 dialog+dialog dialogToRun = runDialogUsingWebkitGtk3 dialogToRun  --------------------------------------------------------------------------------

@@ -22,10 +22,9 @@ import Control.Monad (when) import Control.Monad.IO.Class (MonadIO (..)) import Control.Exception (SomeException, finally, catch)-import Control.Concurrent (forkIO, forkOS)+import Control.Concurrent (forkOS) import Control.Concurrent.MVar (-    MVar, newMVar, newEmptyMVar, readMVar, swapMVar, takeMVar, putMVar,-    tryReadMVar, tryTakeMVar)+    MVar, newMVar, newEmptyMVar, takeMVar, putMVar, tryReadMVar, tryTakeMVar) import Data.Maybe (isNothing) import Data.Monoid ((<>)) import Data.IORef (IORef, newIORef, readIORef, writeIORef)@@ -48,12 +47,6 @@  -------------------------------------------------------------------------------- -data Message =-  Ready |-  AskLineAnswer String----------------------------------------------------------------------------------- data SharedState = SharedState {     shrWindow :: Gtk.Window,     shrWebView :: WV.WebView,@@ -62,14 +55,24 @@     shrNoRunningDialog :: MVar ()   } +data PrivateState = PrivateState {+    privEndMessageRef :: IORef String+  }+ -------------------------------------------------------------------------------- +executeScriptTL :: WV.WebView -> TL.Text -> IO ()+executeScriptTL webView script =+  WV.webViewExecuteScript webView (TL.toStrict script)++--------------------------------------------------------------------------------+ runDialogUsingWebkitGtk3 :: MonadIO m => DialogIO () -> m () runDialogUsingWebkitGtk3 dialog = liftIO $ do   htmlPath <- getDataFileName "html"   let dialogHTML = "file://" ++ (htmlPath </> "dialog.html") -  Gtk.initGUI+  _ <- Gtk.initGUI    webView <- WV.webViewNew   WV.webViewLoadUri webView dialogHTML@@ -80,8 +83,7 @@   window <- Gtk.windowNew   Gtk.windowSetDefaultSize window 900 600   Gtk.widgetSetSizeRequest window 480 320-  GA.set window [Gtk.windowTitle := ("Dialog" :: String)]-  Gtk.on window Gtk.deleteEvent $ do+  _ <- Gtk.on window Gtk.deleteEvent $ do     liftIO Gtk.mainQuit     pure False   Gtk.containerAdd window scrolledWindow@@ -99,25 +101,27 @@       shrNoRunningDialog = noRunningDialog     } -  Gtk.on webView WV.navigationPolicyDecisionRequested $+  _ <- Gtk.on webView WV.navigationPolicyDecisionRequested $      \_ request _ decision -> do-      maybeURI <- liftIO $ NR.networkRequestGetUri request+      maybeURI <- liftIO (NR.networkRequestGetUri request)       case maybeURI of         Just uri -> do           when (uri /= dialogHTML) $ do-            liftIO $ WPD.webPolicyDecisionIgnore decision-            liftIO $ openBrowser uri-            pure ()+            liftIO (WPD.webPolicyDecisionIgnore decision)+            couldOpenBrowser <- liftIO (openBrowser uri)+            when (not couldOpenBrowser) $+              liftIO (executeScriptTL webView +                        ("couldNotOpenBrowser(" <> strJSON uri <> ")"))           pure False         Nothing -> pure False -  Gtk.on webView WV.documentLoadFinished $ \_ -> do+  _ <- Gtk.on webView WV.documentLoadFinished $ \_ -> do     Just document <- WV.webViewGetDomDocument webView      Just scriptOutput <-       Document.getElementById document ("script-output" :: String)     scriptOutputListener <- liftIO $ EventM.newListener $ do-      liftIO $ putMVar wakeUpDialog ()+      liftIO (putMVar wakeUpDialog ())     EventM.addListener scriptOutput Element.click scriptOutputListener False       Just resetButton <-@@ -133,10 +137,6 @@  -------------------------------------------------------------------------------- -data PrivateState = PrivateState {-    privEndMessageRef :: IORef String-  }- runDialogThread :: SharedState -> DialogIO () -> IO () runDialogThread shared dialog = do   endMessageRef <- newIORef "End of program."@@ -153,8 +153,9 @@       (do         stopExistingDialog         clearStatusMVars+        setWindowTitle "Dialog"         postScriptTL "dialogReset()"-        runCommands dialog+        runActions dialog         handleExitRequest            (pure ())           (do@@ -173,31 +174,35 @@         then ifContinuing         else ifExitting +    stopExistingDialog :: IO ()     stopExistingDialog = do       putMVar (shrExitRequested shared) ()       putMVar (shrWakeUpDialog shared) ()-      takeMVar (shrNoRunningDialog shared)+      _ <- takeMVar (shrNoRunningDialog shared)+      pure () +    clearStatusMVars :: IO ()     clearStatusMVars = do-      tryTakeMVar (shrWakeUpDialog shared)-      tryTakeMVar (shrExitRequested shared)+      _ <- tryTakeMVar (shrWakeUpDialog shared)+      _ <- tryTakeMVar (shrExitRequested shared)+      pure ()   -    runCommands :: forall a . DialogIO a -> IO a-    runCommands = \case+    runActions :: forall a . DialogIO a -> IO a+    runActions = \case       Pure value -> pure value       Bind func ->         func handleBind         where           handleBind :: forall b . DialogIO b -> (b -> DialogIO a) -> IO a-          handleBind dialog getNextDialog = do-            result <- runCommands dialog+          handleBind action getNextAction = do+            result <- runActions action             handleExitRequest               undefined-              (runCommands (getNextDialog result))+              (runActions (getNextAction result))       Lift action ->         action       ChangeTitle title ->-        Gtk.postGUISync (GA.set (shrWindow shared) [Gtk.windowTitle := title])+        setWindowTitle title       ChangeEndMessage endMessage ->         writeIORef (privEndMessageRef priv) endMessage       Display paragraphs ->@@ -206,9 +211,13 @@         awaitScriptOutput           (postScriptTL ("dialogAskLine(" <> strJSON prompt <> ")")) +    setWindowTitle :: String -> IO ()+    setWindowTitle title =+      Gtk.postGUISync (GA.set (shrWindow shared) [Gtk.windowTitle := title])++    postScriptTL :: TL.Text -> IO ()     postScriptTL script =-      Gtk.postGUISync-        (WV.webViewExecuteScript (shrWebView shared) (TL.toStrict script))+      Gtk.postGUISync (executeScriptTL (shrWebView shared) script)      awaitScriptOutput :: IO () -> IO String     awaitScriptOutput action = do@@ -225,4 +234,4 @@               (HTMLElement.castToHTMLElement scriptOutput)           pure string) ---------------------------------------------------------------------------------+------------------------------------------------------------------

@@ -0,0 +1,105 @@+--------------------------------------------------------------------------------+-- |+-- module:    Dialog.Shorthands+-- copyright: (c) 2015 Nikita Churaev+-- license:   BSD3+--------------------------------------------------------------------------------++{-# OPTIONS_HADDOCK not-home #-}++--------------------------------------------------------------------------------++module Dialog.Shorthands where++--------------------------------------------------------------------------------++import Dialog.Internal++--------------------------------------------------------------------------------++-- | Shorthand for 'TextParagraph'.+p :: FormattedText -> Paragraph+p = TextParagraph++-- | Makes an unlabeled link. Shorthand for @('Link' url ('Plain' url))@.+url :: String -> FormattedText+url linkURL = Link linkURL (Plain linkURL)++-- | Makes a labeled link. Alias for 'Link'.+link :: String -> FormattedText -> FormattedText+link = Link++-- | Shorthand for @('Picture' ('PictureFromURL' url))@.+img :: String -> Paragraph+img imgURL = Picture (PictureFromURL imgURL)++-- | Makes a numbered list. Shorthand for @('List' 'NumberedList' items)@.+ol :: [ListItem] -> Paragraph+ol = List NumberedList++-- | Makes a bullet list. Shorthand for @('List' 'BulletList' items)@.+ul :: [ListItem] -> Paragraph+ul = List BulletList++-- | Makes a single-line list item. Shorthand for +-- @('ListItem' ['TextParagraph' text])@.+li :: FormattedText -> ListItem+li text = ListItem [TextParagraph text]++-- | Makes a list item. Shorthand for 'ListItem'.+li' :: [Paragraph] -> ListItem+li' = ListItem++-- | Converts a 'String' to a 'FormattedText'. Shorthand for 'Plain'.+str :: String -> FormattedText+str = Plain++-- | Makes a text bold. Shorthand for 'Bold'.+b :: FormattedText -> FormattedText+b = Bold++-- | Makes a text italic. Shorthand for 'Italic'.+i :: FormattedText -> FormattedText+i = Italic++-- | Makes a text underlined. Shorthand for 'Underline'.+u :: FormattedText -> FormattedText+u = Underline++-- | Changes the color of a text. Alias of 'Colored'.+color :: Color -> FormattedText -> FormattedText+color = Colored++-- | Changes the size of a text. Alias of 'Size'.+size :: FontSize -> FormattedText -> FormattedText+size = Size++-- | Makes a table. Alias for 'Table'.+table :: [TableRow] -> Paragraph+table = Table++-- | Makes a table row. Shorthand for 'TableRow'.+tr :: [TableCell] -> TableRow+tr = TableRow++-- | Makes a normal table cell with a single line of text in it. Shorthand for+-- @('TableCell' 'NormalCell' ['TextParagraph' text])@.+td :: FormattedText -> TableCell+td text = TableCell NormalCell [TextParagraph text]++-- | Makes a table header cell with a single line of text in it. Shorthand for+-- @('TableCell' 'HeaderCell' ['TextParagraph' text])@.+th :: FormattedText -> TableCell+th text = TableCell HeaderCell [TextParagraph text]++-- | Makes a normal table cell. Shorthand for+-- @('TableCell' 'NormalCell' paragraphs)@.+td' :: [Paragraph] -> TableCell+td' = TableCell NormalCell++-- | Makes a header table cell. Shorthand for+-- @('TableCell' 'HeaderCell' paragraphs)@.+th' :: [Paragraph] -> TableCell+th' = TableCell HeaderCell++--------------------------------------------------------------------------------