{-| Module : ThreepennyFudgets Description : Fudgets on top of threepenny-gui Maintainer : Thomas Hallgren Stability : Experimental Threepenny Fudgets is a prototype library for writing GUI applications in a functional style in Haskell, using a web browser for the user interface. Threepenny Fudgets is based on (a Graphical User Interface Libary for Haskell developed in the early 1990s) but has a completely separate implementation on top of . -} {-# LANGUAGE TypeOperators #-} module ThreepennyFudgets(-- * The Fudget type F, -- ** Other types type (+),fromLeft,fromRight, URL, -- ** Running a fudget runF,runF', -- * User interface elements buttonF,Click(..),buttonGroupF, toggleButtonF,checkboxF, radioGroupF,radioGroupF',selectF,Options(..), dynSelectF,SelectF,ListRequest(..), sliderF,progressF,meterF, stringDisplayF,htmlDisplayF,showF, numberF,readShowF,stringF,passwordF, canvasF,canvasF',imgF,imgF', --alertF, -- ** Interaction control focusF, disableF, eventF, -- * Static content textF,htmlF,ahrefF, -- * Web page layout --blockF, BlockTag(..), h1F,h2F,h3F,h4F,pF,tableF,divF,boxF,ulF,olF,liF,preF, permuteF, -- ** Traditional Fudgets compatibility shellF,vBoxF,hBoxF, -- ** Changing style and other properties classF,withF,dynWithF,dynF, -- * Fudget plumbing -- | <

> -- ** Parallel composition (>+<),(>+),(+<),listF, -- ** Serial composition (=<=),(=>=), -- ** Loops loopLeftF,loopF,loopThroughRightF, -- * Adding application specific functionality -- ** Stateless mapF,filterF,mapMaybeF,concatMapF, -- ** Stateful stateF,persistentStateF,localStorageF, -- ** Stream manipulation putF,putsF,nullF, idF,concatF,toBothF,throughF,splitF,gatherF,gatherF', -- * Timing timerF,Tick(..), -- * Debugging writeLogF, -- * Internal -- | These definitions reveals implementation details that -- might change. initF,ioF,elemDisplayF,modifyF,H, -- * Threepenny extras -- ** Attributes Attribute,(=:),attr,style,setMany, -- ** Drawing on a canvas -- | See also "Graphics.UI.Threepenny.Canvas" Picture(..),UI.Point,circle,line,strokePath,fillPath, -- * Other utilities chop,readM ) where import qualified Data.Aeson as JSON import qualified Graphics.UI.Threepenny as UI import Graphics.UI.Threepenny.Core -- Overkill, since we are creating single-threaded programs import Control.Concurrent.MVar--(newMVar,takeMVar,readMVar,putMVar) import Data.List(findIndex) import Control.Monad(unless,when,zipWithM,(<=<)) import System.Directory import System.Environment import System.IO.Error -- | @F hi ho@ is the type of a fudget that -- consumes an high-level input stream of values of type @hi@ and -- produces an high-level output stream of values of type @ho@. -- It can also generate a number of user interface elements, -- and can read input from and send output to those user interface elements. -- <

> newtype F hi ho = F (H ho->UI (H hi,[Element])) -- | The type of an event handler type H a = a -> UI () -- | 'runF' is typically used only once in the @main@ function of a program. -- It runs the fudget and adds any user interface elements it generates -- to the 'documentBody' of the web page. runF :: F hi ho -> IO () runF = runF' (const (return ())) runF' init (F fud) = startGUI config $ \ window -> do init window (_,es) <- fud ignore getBody window #+ map pure es return () where config = defaultConfig {jsStatic=Just "static"} initF init fud = F $ \ oh -> do a <- init let F f = fud a f oh {- instance Monoid (F hi ho) where mempty = nullF mappend (F f1) (F f2) = F $ \ oh -> do (_,es1) <- f1 oh (_,es2) <- f2 oh return (ignore,es1++es2) -} instance Functor (F hi) where fmap f (F fud) = F $ \ oh -> fud (oh . f) instance Applicative (F hi) where pure ho = putF ho nullF ff <*> fa = mapF (uncurry id) =<= gatherF =<= (ff>++ fr = mapMaybeF fromRight =<= (fl>+ return (f oh,[]) ioF io = F $ \ oh -> return (oh <=< (liftIO . io),[]) -- | @putF x fud@ outputs @x@, then behaves like fud putF x (F fud) = F $ \ oh -> do oh x; fud oh -- | @putF xs fud@ outputs @xs@, then behaves like fud putsF :: [ho] -> F hi ho -> F hi ho putsF xs (F fud) = F $ \ oh -> do mapM_ oh xs; fud oh nullF = absF (const ignore) -- ^ Ignores all input. Doesn't produce any output. idF = absF id -- ^ @mapF id@, propagates all input directly to the output mapF f = absF (. f) -- ^ Like 'map' for lists. @mapF f@ outputs @f x@ for every @x@ in the input stream mapMaybeF f = absF (\oh->maybe (return ()) oh . f) -- ^ Like 'mapMaybe' for lists. A combination of 'mapF' and 'filterF'. filterF p = mapMaybeF (\x->if p x then Just x else Nothing) -- ^ Like 'filter' for lists. Propagates values from the input stream to -- the output stream if they pass a test. stateF :: (s -> hi -> (s,[ho])) -> s -> F hi ho stateF f init = F $ \ oh -> do state <- liftIO $ newMVar init let ih i = do old <- liftIO $ takeMVar state let (new,out) = f old i liftIO $ putMVar state new mapM_ oh out return (ih,[]) -- ^ @stateF@ is used to maintain an internal state. -- Given a state transition function @f@ and an initial state @s@, -- @stateF f s@ responds to input by applying @f@ to it to update the -- internal state and generate zero or more output messages. -- | Like 'concat' for lists, flattens a stream of lists. concatF :: F [i] i concatF = absF mapM_ -- | Like 'concatMap' for lists. A combination of 'concatF' and 'mapF'. concatMapF :: (i->[o]) -> F i o concatMapF f = absF (\oh -> mapM_ oh . f) toBothF :: F a (a+a) toBothF = concatMapF (\x->[Left x,Right x]) throughF fud = either id id <$> (fud >+< idF) =<= toBothF splitF :: F (a,b) (a+b) splitF = concatMapF (\(x,y)->[Left x,Right y]) -- | After the first @Left a@ and @Right b@ has arrived on the input, @gatherF@ -- output pairs @(a,b)@ with the most recent @a@ and @b@ values received. gatherF :: F (a+b) (a,b) gatherF = gatherF'' (Nothing,Nothing) -- | 'gatherF' with initial values. gatherF' :: (a,b) -> F (a+b) (a,b) gatherF' (a,b) = gatherF'' (Just a,Just b) gatherF'' :: (Maybe a,Maybe b) -> F (a+b) (a,b) gatherF'' = stateF gather where gather (_,Just b) (Left a) = ((Just a,Just b),[(a,b)]) gather (_,n) (Left a) = ((Just a,n),[]) gather (Just a,_) (Right b) = ((Just a,Just b),[(a,b)]) gather (n,_) (Right b) = ((n,Just b),[]) -------------------------------------------------------------------------------- infixr 3 =<=,=>= -- | Right-to-left serial composition. The output stream of the right fudget -- is connected to the input stream of the left fudget. This was -- originally called '>==<' in Fudgets. F f1 =<= F f2 = F $ \ oh -> do (ih1,es1) <- f1 oh (ih2,es2) <- f2 ih1 return (ih2,es1++es2) -- | Left-to-right serial composition. The output stream of the left fudget -- is connected to the input stream of the right fudget. (This was not -- included in the original implementation of Fudgets. Using both '=>=' -- and '=<=' in the same expression might lead to confusion...) F f1 =>= F f2 = F $ \ oh -> do (ih2,es2) <- f2 oh (ih1,es1) <- f1 ih2 return (ih1,es1++es2) -- | We use the notation @a+b@ for @'Either' a b@, -- the standard disjoint union type in Haskell. type a+b = Either a b infixl 5 >+<,+<,>+ -- | Tagged parallel composition. Messages to/from the left fudget are -- tagged 'Left'. Messages to/from the right fudget are tagged 'Right'. (>+<) :: F i1 o1 -> F i2 o2 -> F (i1+i2) (o1+o2) F f1 >+< F f2 = F $ \ oh -> do (ih1,es1) <- f1 (oh . Left) (ih2,es2) <- f2 (oh . Right) return (either ih1 ih2,es1++es2) -- | Parallel composition where only the right fudget is connected. -- The left fudget is typically static content. F f1 +< F f2 = F $ \ oh -> do (ih1,es1) <- f1 ignore (ih2,es2) <- f2 oh return (ih2,es1++es2) -- | Parallel composition where only the left fudget is connected. -- The right fudget is typically static content. F f1 >+ F f2 = F $ \ oh -> do (ih1,es1) <- f1 oh (ih2,es2) <- f2 ignore return (ih1,es1++es2) -- | Tagged parallel composition of a list of fudgets listF tfs = F $ \ oh -> do (ihs,ess) <- unzip <$> sequence [f (oh . (,) t) | (t,F f)<-tfs] let tihs = zip (map fst tfs) ihs ih (t,i) = maybe (return ()) ($ i) (lookup t tihs) return (ih,concat ess) -------------------------------------------------------------------------------- -- | Creates a feedback loop. @loopLeftF fud@ behaves as follows: -- output from @fud@ tagged @Left@ will be sent back to -- the input of @fud@. Output from @fud@ tagged @Right@ will be sent to the -- output of @loopLeftF fud@. Input to @loopLeftF fud@ will be tagged -- @Right@ and delivered to @fud@. loopLeftF :: F (loop+hi) (loop+ho) -> F hi ho loopLeftF (F fud) = F $ \ oh -> do (ev,ih) <- liftIO newEvent --let ih x = do putStrLn "ih"; ih0 x q <- liftIO $ newMVar (Left []) let eih x = takeMVar q >>= either (putMVar q . Left . (x:)) (\ ih->putMVar q (Right ih)>>ih x) --let oh x = do liftIO (putStrLn "oh "); oh0 x (ih',es) <- fud (either (liftIO . eih . Left) oh) --let ih' x = do liftIO (putStrLn "ih' "); ih0' x --liftIO $ putStrLn "onEvent" onEvent ev ih' Left xs <- liftIO $ takeMVar q liftIO $ putMVar q (Right ih) liftIO $ mapM_ ih (reverse xs) return (liftIO . ih . Right,es) -- | Copy output back to the input. The fudget needs to send on average -- strictly less than one output message per input message, otherwise it -- will become busy reacting to its own messages. loopF fud = loopLeftF (toBothF =<= fud =<= mapF (either id id)) -- | @loopThroughRightF master slave@ is similar to loopLeftF master, but -- the loop goes through the @slave@ fudget. (A better name might be -- @encapsulateF@ since all communication with the @slave@ has to go via -- the @master@, so the @slave@ is encapsulated in this sense.) --loopThroughRightF :: F (ro+hi) (ri+ho) -> F ri ro -> F hi ho loopThroughRightF lfud rfud = loopCompThroughRightF (lfud>+ F hi ho loopCompThroughRightF w = let post (Left (Left x)) = Left (Right x) post (Left (Right x)) = Right x post (Right x) = Left (Left (Left x)) pre (Left x) = x pre (Right x) = Left (Right x) in loopLeftF (prepostMapHigh pre post w) prepostMapHigh pre post fud = post <$> fud =<= mapF pre -------------------------------------------------------------------------------- {- data BlockTag = DIV | P | H1 | H2 | H3 | H4 | H5 | H6 | UL | OL | PRE deriving (Eq,Ord,Enum,Bounded,Show) blockF t = wrapF (show (t::BlockTag)) -} divF = wrapF "div" -- ^ A div element @\

...\
@ pF = wrapF "p" -- ^ Paragraph @\

...\

@ h1F = wrapF "h1" -- ^ Level 1 header @\

...\

@ h2F = wrapF "h2" -- ^ Level 2 header @\

...\

@ h3F = wrapF "h3" -- ^ Level 3 header @\

...\

@ h4F = wrapF "h4" -- ^ Level 4 header @\

...\

@ ulF = wrapF "ul" -- ^ Unordered list @\@ olF = wrapF "ol" -- ^ Ordered list @\
    ...\
@ liF = wrapF "li" -- ^ List item @\
  • ...\
    • @ -- | A div element with a black border and some padding boxF = wrapF' "div" (set style [("border","1px solid black"), ("padding","1ex"), ("margin","1ex")]) preF = wrapF "pre" -- ^ A pre element @\
    ...\
    @ wrapF = layoutF . wrap wrapF' tagname as = layoutF (wrap' tagname as) layoutF layout = modifyElemsF (fmap (:[]) . layout) permuteF perm = modifyElemsF (pure . perm) -- ^ Rearrange the elements generated by a fudget. Note that 'Element's -- can not be duplicated. modifyElemsF f = modifyF (const f) modifyF modify (F fud) = F $ \ oh -> do (ih,es) <- fud oh es' <- modify oh es return (ih,es') -- | Add event handlers to the elements generated by a fudget. -- Event types can be imported from "Graphics.UI.Threepenny.Events". eventF evs h = modifyF modify where modify oh es = do sequence_ [on ev el (oh . curry h ev )|el<-es,ev<-evs] return es -- | Set the @class@ attribute of the elements generated by a fudget classF fud cls = withF fud [attr "class"=:cls] -- | Apply attributes to the elements generated by a fudget withF fud as = modifyElemsF (mapM (setMany as.pure)) fud -- | Dynamically change element attributes dynWithF :: F hi ho -> F ([Attribute]+hi) ho dynWithF = dynModF dynWith where dynWith es as = mapM_ (setMany as.pure) es -- | Disable and enable buttons and other input elements. disableF :: F hi ho -> F (Bool+hi) ho disableF = dynModF disable where disable es b = sequence_ [e # set' UI.enabled (not b) | e<-es] -- | Allows you to observe and control the focus of a fudget. (Focus -- determines where keyboard input goes.) focusF :: F hi ho -> F (Bool+hi) (Bool+ho) focusF (F fud) = F $ \ oh -> do (ih,es@(el:_)) <- fud (oh . Right) on UI.focus el $ \ _ -> oh (Left True) on UI.blur el $ \ _ -> oh (Left False) let --fb True = focus el --fb False = blur el fb _ = return () -- !!! return (either fb ih,es) dynModF mod (F fud) = F $ \ oh -> do (ih,es) <- fud oh return (either (mod es) ih,es) -- | A fudget that can be replaced dynamically dynF :: F i o -> F (F i o + i) o dynF (F fud) = F $ \ oh -> do el <- mkElement "span" (ih0,els0) <- fud oh pure el #+ (map pure els0) ihvar <- liftIO $ newMVar ih0 let ih = either new input input i = ($ i) =<< liftIO (readMVar ihvar) new (F fud) = do _ <- liftIO $ takeMVar ihvar (ih',els') <- fud oh el # set' UI.children els' liftIO $ putMVar ihvar ih' return (ih,[el]) -- | With traditional Fudgets, 'shellF' creates top-level application windows. -- With WebFudgets, using 'shellF' is entierly optional. It just puts a -- title above another fudget and adds a couple of @\
    @ elements that -- can be styled to look like a traditional application window with a -- title bar, if you wish. -- @\
    \

    /title/\<\/h4>\
    ...\<\/div>\<\/div>@ shellF title fud = divF (h4F (textF title) +< divF fud) `classF` "shellF" -- | Place elements vertically vBoxF = layoutF vBoxL -- | Place elements horizontally hBoxF = layoutF hBoxL -- | A table with @n@ columns. The elements generated by the -- argument fudget are placed in separate table cells. tableF n fud = layoutF (tableL n) fud `classF` "table" tableL n es = do tds <- mapM (wrap1 "td") es rows <- mapM (wrap "tr") (chop n tds) wrap "table" rows vBoxL es = tableL 1 es #. "vbox" hBoxL es = tableL (length es) es #. "hbox" -- | Plain text textF = staticF . string -- | Text with HTML markup htmlF s = staticF (htmlElem s) htmlElem s = mkElement "span" # set html s staticF haste = F $ const ((,) ignore . (:[]) <$> haste) -- | A hyperlink @\...\@ ahrefF :: URL -> F i o -> F i o ahrefF url = layoutF (wrap' "a" (set UI.href url)) -------------------------------------------------------------------------------- -- | An image, @\@ -- You can change the image dynamically by sending in the URL of another -- image. imgF :: URL -> F URL o imgF = imgF' (set UI.alt "") -- | An image with extra attributes, @\@. -- You can change the image dynamically by sending in the URL of another -- image. imgF' :: Attribute -> URL -> F URL o imgF' as url = F $ \ oh -> do el <- mkElement "img" let ih url = do pure el # set UI.src url return () ih url pure el # as return (ih,[el]) -- | 'stringF' combined with 'show', marked read-only showF :: Show i => F i o showF = nullF =<= stringF `withF` as =<= mapF show where as = [attr "readonly"=:"readonly"] -- | An output-only element displaying text, @\...\@ stringDisplayF = elemDisplayF Nothing =<= mapF (set text) -- | An output-only element displaying HTML content htmlDisplayF = elemDisplayF Nothing =<= mapF (set html) elemDisplayF :: Maybe (UI Element->UI a) -> F (UI Element->UI b) o elemDisplayF init = F $ \ oh -> do el <- mkElement "span" let ih m = do pure el # m return () maybe (return ()) ih init return (ih,[el]) -- | 'stringF' combined with 'show' and 'read' readShowF :: (Show a,Read a) => F a a readShowF = mapMaybeF readM =<= stringF =<= mapF show -- | 'readShowF' restricted to numbers, @\@ numberF :: (Show a,Read a,Num a) => F a a numberF = mapMaybeF readM =<= inputF "number" =<= mapF show -- | A string input/output field, @\@ stringF = inputF "text" -- | A string input/output field that shows @****@ instead of the actual -- input, @\@ passwordF = inputF "password" -- | A slider which lets you choose a value from an enumeration, -- @\@ sliderF :: Enum a => (a,a) -> F a a sliderF (low,high) = toEnum.read <$> qInputF' "range" attrs =<= mapF (show.fromEnum) where attrs = [set (attr "min") (show (fromEnum low)), set (attr "max") (show (fromEnum high))] -- | A progress meter -- @\\<\/meter>@ progressF :: (Num i,Ord i,Show i) => i -> F i o progressF max = F $ \ oh -> do el <- mkElement "progress" # set (attr "max") (show max) let ih v = do pure el # set value (show v) return () return (ih,[el]) -- | A meter for scalar value between given minimum and maximum. -- @\\<\/meter>@ meterF :: (Num i,Ord i,Show i) => (i,i) -> F i o meterF (min,max) = F $ \ oh -> do el <- mkElement "meter" # set (attr "min") (show min) # set (attr "max") (show max) let ih v = do pure el # set value (show v) return () return (ih,[el]) {- -- Meter implemented as a canvasF --meterF :: F Double x meterF = nullF =<= canvasF (width,height) `withF` attrs =<= mapF bar where attrs = [style "border"=:"1px solid black"] width,height :: Num a => a width = 150 height = 18 bar d = color (RGB 0 0 240) $ fill $ rect (0,0) (d*width,height) -} inputF ty = inputF' ty [] inputF' = inputF'' valueChange' (const True) qInputF' = inputF'' valueInput' (const True) inputF'' ev p ty ps = F $ \ oh -> do inp <- mkElement "input" # set UI.type_ ty # setMany ps on ev inp $ \ed -> do when (p ed) (oh =<< get value inp) let ih s = do pure inp # set value s --when isText (select inp) return () return (ih,[inp]) where isText = ty `elem` ["number","text","password"] data Click = Click deriving (Eq,Show,Read) -- | Creates a button, like @\@. -- It outputs 'Click' when pressed. ('Click' received on the input -- is propagated directly to the output, allowing button clicks to -- be simulated programmatically.) buttonF lbl = F $ \ oh -> do btn <- mkElement "input" # set UI.type_ "button" # set value lbl on UI.click btn $ \_ -> oh Click return (oh,[btn]) -- | Creates a button with another fudget inside (which -- should be something simple, e.g. an 'imgF' or a 'stringDisplayF'...), -- @\