lgtk 0.6 → 0.8
raw patch · 33 files changed
+3294/−2120 lines, 33 filesdep +GLFW-bdep +JuicyPixelsdep +OpenGLRawdep −SVGFontsdep ~containersdep ~diagrams-cairodep ~diagrams-libnew-component:exe:lgtkdemo
Dependencies added: GLFW-b, JuicyPixels, OpenGLRaw, array, cairo, colour, filepath, lensref, lgtk, monad-control, random, random-shuffle, semigroups, vector
Dependencies removed: SVGFonts
Dependency ranges changed: containers, diagrams-cairo, diagrams-lib, directory, fsnotify, groups, gtk, lens, mtl, operational, system-filepath, transformers
Files
- changelog +57/−0
- lgtk.cabal +107/−35
- lgtkdemo/Data/Equivalence/Persistent.hs +166/−0
- lgtkdemo/LGtk/ADTEditor.hs +100/−0
- lgtkdemo/LGtk/Demos/IntListEditor.hs +100/−0
- lgtkdemo/LGtk/Demos/Main.hs +439/−0
- lgtkdemo/LGtk/Demos/Maze.hs +183/−0
- lgtkdemo/LGtk/Demos/Maze/Maze.hs +89/−0
- lgtkdemo/LGtk/Demos/Maze/Types.hs +31/−0
- lgtkdemo/LGtk/Demos/MazeGen.hs +63/−0
- lgtkdemo/LGtk/Demos/TEditor.hs +54/−0
- lgtkdemo/LGtk/Demos/Tri.hs +39/−0
- lgtkdemo/Main.hs +5/−0
- src/Control/Monad/EffRef.hs +0/−298
- src/Control/Monad/ExtRef.hs +0/−298
- src/Control/Monad/ExtRef/Pure.hs +0/−127
- src/Control/Monad/ExtRef/Test.hs +0/−289
- src/Control/Monad/Restricted.hs +0/−64
- src/Data/Lens/Common.hs +0/−67
- src/GUI/Gtk/Structures.hs +0/−60
- src/GUI/Gtk/Structures/IO.hs +0/−302
- src/LGtk.hs +165/−133
- src/LGtk/ADTEditor.hs +0/−100
- src/LGtk/Backend/GLFW.hs +390/−0
- src/LGtk/Backend/Gtk.hs +359/−0
- src/LGtk/Demos/IntListEditor.hs +0/−90
- src/LGtk/Demos/Main.hs +0/−164
- src/LGtk/Demos/TEditor.hs +0/−54
- src/LGtk/Demos/Tri.hs +0/−39
- src/LGtk/Effects.hs +254/−0
- src/LGtk/Key.hs +47/−0
- src/LGtk/Render.hs +564/−0
- src/LGtk/Widgets.hs +82/−0
+ changelog view
@@ -0,0 +1,57 @@++= lgtk-0.8 =++Lots of changes since the previously announced version, lgtk-0.5.3.++== New features ==++* New GLFW backend - Gtk is not strictly needed any more+* Diagrams canvas with mouse and keyboard interaction support+* Widget rendering in canvas+* Horizontal sliders (called scales in Gtk)+* Updated demo application++== Architectural changes ==++* Lens references splitted off to the separate package lensref.+* Switch from data-lens to Edward Kmett's lens library+* Upgrade to work with GHC 8.2+* Repository moved to GitHub++== Inner changes ==++* Cleaned up widgets interface: simpler inner representation of widgets; eliminate `SafeIO` and `action`++== Other changes ==++* Bugfixes+++= lgtk-0.5.3 =++* bugfix: handle focus out events for entries+* bugfix: run postponed actions at widget initialization++= lgtk-0.5.2 =++* Better support for references with equality+* Documentation fixes and cleanup+* Inner change: safer state handling with MVars++= lgtk-0.5.1 =++* Documentation fixes and cleanup+* Try to support Haskell Platform 2012.4.0.0++= lgtk-0.5 =++* Do not use monadic lenses any more.+* Support for asynchronous events.+* Lazily created tabs.+* Inactive tabs are really inactive (event handlers are detached).+* File references watch the files. When the file changes, the GUI is updated.+* References with inherent identity (makes defining auto-sensitive buttons easier)+* Experimental support for coloured buttons.+* More examples in the demo application.+* Lots of inner changes.+
lgtk.cabal view
@@ -1,23 +1,47 @@ name: lgtk-version: 0.6+version: 0.8 category: GUI-synopsis: lens-based API for Gtk+synopsis: Lens GUI Toolkit description:- The main interface module of LGtk is "LGtk".+ LGtk is a GUI Toolkit.+ .+ Main goals of LGtk:+ .+ -Provide a Haskell EDSL for declarative description of interactive graphical applications+ .+ -Provide an API for custom widget design+ .+ -Provide a playground for high-level declarative features like+ derived state-save and undo-redo operations and+ type-driven GUI generation+ .+ For more information visit the following links:+ .+ -<http://www.haskell.org/haskellwiki/LGtk haskell.org wiki page>+ .+ -<http://lgtk.wordpress.com/ Wordpress blog>+ .+ -<https://github.com/divipp/lgtk GitHub repository>+ .+ -<http://hackage.haskell.org/package/lgtk Haddock documentation (this page)> stability: experimental license: BSD3 license-file: LICENSE author: Péter Diviánszky homepage: http://www.haskell.org/haskellwiki/LGtk-bug-reports: http://hub.darcs.net/divip/lgtk/issues+bug-reports: https://github.com/divipp/lgtk/issues maintainer: divipp@gmail.com cabal-version: >= 1.8 build-type: Simple+extra-source-files: changelog source-repository head- type: darcs- location: http://hub.darcs.net/divip/lgtk+ type: git+ location: https://github.com/divipp/lgtk.git +Flag Gtk+ Description: Build the Gtk backend+ Default: False library @@ -25,48 +49,98 @@ src build-depends: base < 5- , containers- , directory- , system-filepath- , fsnotify - , transformers- , mtl- , operational+ , groups == 0.4.*+ , semigroups >= 0.13 && < 0.15+ , transformers >= 0.3 && < 0.5+ , mtl >= 2 && < 2.3+ , monad-control == 0.3.*+ , operational == 0.2.*+ , lens == 4.1.* - , gtk+ , vector == 0.10.*+ , containers == 0.5.*+ , directory == 1.2.*+ , filepath == 1.3.*+ , system-filepath == 0.4.*+ , fsnotify == 0.0.* + , colour == 2.3.*+ , JuicyPixels == 3.1.*+ , diagrams-lib == 1.1.*+ , diagrams-cairo == 1.1.*+ , cairo == 0.12.*+-- , SVGFonts == 1.4.*+ , OpenGLRaw == 1.4.*+ , GLFW-b == 1.4.* -- , threepenny-gui == 0.4.1.* - , diagrams-lib- , diagrams-cairo- , SVGFonts- , groups+ , lensref == 0.1.* - , lens exposed-modules:+ -- lgtk LGtk+ other-modules:+ -- lgtk+ LGtk.Effects+ LGtk.Key+ LGtk.Widgets+ LGtk.Render - LGtk.ADTEditor+ -- lgtk-glfw+ LGtk.Backend.GLFW+ if flag(Gtk)+ build-depends:+ gtk == 0.12.*+ other-modules:+ LGtk.Backend.Gtk+ cpp-options:+ -D__GTK__ + ghc-options: + -threaded+ -Wall + -fno-warn-incomplete-patterns + -fno-warn-name-shadowing + -fno-warn-missing-signatures + -fno-warn-orphans+ -fno-warn-type-defaults+++executable lgtkdemo+ build-depends:+ base < 5++ , mtl >= 2 && < 2.3+ , lens == 4.1.*++ , containers == 0.5.*+ , vector == 0.10.*+ , array == 0.5.*+ , random == 1.0.*+ , random-shuffle == 0.0.*++ , diagrams-lib == 1.1.*++ , lgtk+ main-is:+ Main.hs+ other-modules:+ Data.Equivalence.Persistent++ LGtk.ADTEditor LGtk.Demos.Main LGtk.Demos.Tri LGtk.Demos.IntListEditor LGtk.Demos.TEditor- other-modules:- Data.Lens.Common-- Control.Monad.Restricted-- Control.Monad.ExtRef- Control.Monad.ExtRef.Pure- Control.Monad.ExtRef.Test-- Control.Monad.EffRef+ LGtk.Demos.Maze.Types+ LGtk.Demos.Maze.Maze+ LGtk.Demos.MazeGen+ LGtk.Demos.Maze - GUI.Gtk.Structures- GUI.Gtk.Structures.IO- ghc-options: + hs-source-dirs:+ lgtkdemo+ ghc-options: -threaded -Wall -fno-warn-incomplete-patterns @@ -74,6 +148,4 @@ -fno-warn-missing-signatures -fno-warn-orphans -fno-warn-type-defaults--
+ lgtkdemo/Data/Equivalence/Persistent.hs view
@@ -0,0 +1,166 @@+{-|+ Code for manipulation of equivalence classes on index types. An+ 'Equivalence' is an equivalence relation. The empty equivalence relation+ is constructed over a ranges of values using 'emptyEquivalence'. Less+ discerning equivalence relations can be obtained with 'equate' and+ 'equateAll'. The relation can be tested with 'equiv' and 'equivalent'.++ An example follows:++ > import Data.Equivalence.Persistent+ >+ > rel = equateAll [1,3,5,7,9]+ > . equate 5 6+ > . equate 2 4+ > $ emptyEquivalence (1,10)+ >+ > test1 = equiv rel 3 5 -- This is True+ > test2 = equiv rel 1 6 -- This is True+ > test3 = equiv rel 4 6 -- This is False+-}+module Data.Equivalence.Persistent (+ Equivalence,+ emptyEquivalence,+ domain,+ equiv,+ equivalent,+ equate,+ equateAll+ )+ where++import Control.Concurrent.MVar+import Control.Monad+import Data.Array.IArray+import Data.IORef+import Data.List+import Data.Maybe+import System.IO.Unsafe++type DiffArray = Array++arrayFrom :: (IArray a e, Ix i) => (i,i) -> (i -> e) -> a i e+arrayFrom rng f = array rng [ (x, f x) | x <- range rng ]++{-+ Convenience method for building "transparent" references. These must+ have the property that updating them makes no semantic change in their+ value; otherwise, references really need to be created in an IO block.+-}+ref :: a -> IORef a+ref x = unsafePerformIO (newIORef x)++{-|+ An 'Equivalence' is an equivalence relation on a range of values of some+ index type.+-}+data Equivalence i = Equivalence {+ ranks :: DiffArray i Int,+ parents :: IORef (DiffArray i i)+ }++{-|+ 'emptyEquivalence' is an equivalence relation that equates two values+ only when they are equal to each other. It is the most discerning such+ relation possible.+-}+emptyEquivalence :: Ix i => (i, i) -> Equivalence i+emptyEquivalence is = Equivalence (arrayFrom is (const 0))+ (ref (arrayFrom is id))++{-|+ Gets the domain of an equivalence relation, as the ordered pair of index+ bounds.+-}+domain :: Ix i => Equivalence i -> (i, i)+domain (Equivalence rs _) = bounds rs+++reprHelper :: Ix i => DiffArray i i -> i -> (Maybe (DiffArray i i), i)+reprHelper ps i+ | pi == i = (Nothing, i)+ | otherwise = let (ps', r) = reprHelper ps pi+ in (Just (fromMaybe ps ps' // [(i,r)]), r)+ where pi = ps ! i++{-+ 'repr' gives a canonical representative of the equivalence class+ containing @x@. It is chosen arbitrarily, but is always the same for a+ given class and 'Equivalence' value.++ This is not exported, because clients that use this are doing something+ wrong. Note that:++ * The representative chosen depends on the order in which the+ equivalence relation was built, and is not always the same for+ values that represent the same relation.++ * The representative is not particularly stable. Uses of 'equate' are+ highly likely to change it.++ * If all you need is some representative of the equivalence class,+ you have to provide one as input to the function anyway, so you+ may as well use that.++ The only guarantee provided is that repr always returns the same value for+ the exact same 'Equivalence'.+-}+repr :: Ix i => Equivalence i -> i -> i+repr (Equivalence rs vps) i = unsafePerformIO $ do+ ps <- readIORef vps+ let (ps', r) = reprHelper ps (ps ! i)+ maybe (return ()) (writeIORef vps) ps'+ return r++{-|+ Determines if two values are equivalent under the given equivalence+ relation.+-}+equiv :: Ix i => Equivalence i -> i -> i -> Bool+equiv eq x y = repr eq x == repr eq y++{-|+ Determines if all of the given values are equivalent under the given+ equivalence relation.+-}+equivalent :: Ix i => Equivalence i -> [i] -> Bool+equivalent eq [] = True+equivalent eq (x:xs) = all (== repr eq x) (map (repr eq) xs)++{-|+ Construct the equivalence relation obtained by equating the given two+ values. This combines equivalence classes.+-}+equate :: Ix i => i -> i -> Equivalence i -> Equivalence i+equate x y (Equivalence rs vps) = unsafePerformIO $ do+ ps <- readIORef vps+ let (ps', px) = reprHelper ps x+ (ps'', py) = reprHelper (fromMaybe ps ps') y+ psFinal <- case ps' of+ Nothing -> do maybe (return ()) (writeIORef vps) ps''+ return (fromMaybe ps ps'')+ Just t -> do writeIORef vps (fromMaybe t ps'')+ return (fromMaybe t ps'')+ return (go px py psFinal)+ where+ go px py ps+ | px == py = Equivalence rs vps+ | rx > ry = let ps' = ps // [(py, px)]+ in Equivalence rs (ref ps')+ | rx < ry = let ps' = ps // [(px, py)]+ in Equivalence rs (ref ps')+ | otherwise = let ps' = ps // [(py, px)]+ rs' = rs // [(px, (rx + 1))]+ in Equivalence rs' (ref ps')+ where rx = rs ! px+ ry = rs ! py++{-|+ Construct the equivalence relation obtained by equating all of the given+ values. This combines equivalence classes.+-}+equateAll :: Ix i => [i] -> Equivalence i -> Equivalence i+equateAll [] eq = eq+equateAll (x:xs) eq = foldl' (flip (equate x)) eq xs++
+ lgtkdemo/LGtk/ADTEditor.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+-- | A generic ADT editor defined on top of the main LGtk interface, "LGtk".+module LGtk.ADTEditor+ ( Lens_ (..), List (..), Elems(..), ADTLens(..)+ , adtEditor+ ) where++import Control.Monad+import Control.Lens hiding (Cons)+import LGtk++newtype Lens_ a b = Lens_ {unLens_ :: Lens' a b}++-- | Type-level lists+data List a = Nil | Cons a (List a)++-- | Heterogeneous lists+data Elems (xs :: List *) where+ ElemsNil :: Elems Nil+ ElemsCons :: ADTLens a => a -> Elems as -> Elems (Cons a as)++{- | Lens for editable ADTs with support of shared record fields between constructors.++Suppose we have the data type++@+data X+ = X1 { a :: Int, b :: Bool }+ | X2 { a :: Int, c :: Char }+@++We can build an editor which can switch between two editor for the constructors.+If the field @a@ is edited in one editor, it will be updated in the other.+-}+class ADTLens a where++ {- | @ADTEls a@ is the list of types of the parts of the ADT.++ For example,++ @ADTEls X = Cons Int (Cons Bool (Cons Char Nil))@+ -}+ type ADTEls a :: List *++ {- | The lens which defines an abstract editor.++ The first parameter defines the displayed constructor name and the parts of the constructor for each constructor.+ @Int@ is an index in the @ADTEls@ list.++ For example, in case of @X@,++ @fst3 adtLens = [(\"X1\", [0, 1]), (\"X2\", [0, 2])]@++ The second parameter is the list of default values for each part.++ The third parameter is a lens from the selected constructor index plus+ the values of the ADT parts to the ADT values.+ -}+ adtLens :: ([(String, [Int])], Elems (ADTEls a), Lens_ (Int, Elems (ADTEls a)) a)++-- | A generic ADT editor+adtEditor :: (MonadRegister m, ADTLens a) => Ref m a -> m (Widget m)+adtEditor = memoRead . editor where+ editor r = do+ q <- extRef r k (0, ls)+ es <- mkEditors ls $ _2 `lensMap` q+ hcat+ [ combobox (map fst ss) $ _1 `lensMap` q+ , cell (liftM fst $ readRef q) $ \i -> vcat [es !! j | j <- snd $ ss !! i]+ ]+ where+ (ss, ls, Lens_ k) = adtLens++ mkEditors :: MonadRegister m => Elems xs -> Ref m (Elems xs) -> m [Widget m]+ mkEditors ElemsNil _ = return []+ mkEditors (ElemsCons _ xs) r = do+ i <- adtEditor $ lHead `lensMap` r+ is <- mkEditors xs $ lTail `lensMap` r+ return $ i : is+ where+ lHead :: Lens' (Elems (Cons x xs)) x+ lHead = lens get set where+ get :: Elems (Cons x xs) -> x+ get (ElemsCons a _) = a+ set :: Elems (Cons x xs) -> x -> Elems (Cons x xs)+ set (ElemsCons _ as) a = ElemsCons a as++ lTail :: Lens' (Elems (Cons x xs)) (Elems xs)+ lTail = lens get set where+ get :: Elems (Cons x xs) -> Elems xs+ get (ElemsCons _ as) = as+ set :: Elems (Cons x xs) -> Elems xs -> Elems (Cons x xs)+ set (ElemsCons a _) as = ElemsCons a as++
+ lgtkdemo/LGtk/Demos/IntListEditor.hs view
@@ -0,0 +1,100 @@+-- | An integer list editor+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module LGtk.Demos.IntListEditor where++import Control.Monad+import Data.List (sortBy)+import Data.Function (on)++import Control.Lens+import LGtk++intListEditor+ :: forall m a+ . (MonadRegister m, Read a, Show a, Integral a)+ => (a, Bool) -- ^ default element+ -> Int -- ^ maximum number of elements+ -> Ref m [(a, Bool)] -- ^ state reference+ -> Ref m Bool -- ^ settings reference+ -> Widget m+intListEditor def maxi list_ range = do+ (undo, redo) <- undoTr ((==) `on` map fst) list_+ notebook+ [ (,) "Editor" $ vcat+ [ hcat+ [ entryShow len+ , vcat+ [ hcat+ [ smartButton (return "+1") len (+1)+ , smartButton (return "-1") len (+(-1))+ , smartButton (liftM (("DeleteAll " ++) . show) $ readRef len) len $ const 0+ ]+ , hcat+ [ button (return "undo") undo+ , button (return "redo") redo+ ]+ ]+ ]+ , hcat+ [ smartButton (return "+1") list $ map $ over _1 (+1)+ , smartButton (return "-1") list $ map $ over _1 (+(-1))+ , smartButton (return "sort") list $ sortBy (compare `on` fst)+ ]+ , hcat+ [ smartButton (return "SelectAll") list $ map $ set _2 True+ , smartButton (return "SelectPos") list $ map $ \(a,_) -> (a, a>0)+ , smartButton (return "SelectEven") list $ map $ \(a,_) -> (a, even a)+ , smartButton (return "InvertSel") list $ map $ over _2 not+ ]+ , hcat+ [ smartButton (liftM (("DelSel " ++) . show . length) sel) list $ filter $ not . snd+ , smartButton (return "CopySel") safeList $ concatMap $ \(x,b) -> (x,b): [(x,False) | b]+ , smartButton (return "+1 Sel") list $ map $ mapSel (+1)+ , smartButton (return "-1 Sel") list $ map $ mapSel (+(-1))+ ]+ , label $ liftM (("Sum: " ++) . show . sum . map fst) sel+ , listEditor def (map itemEditor [0..]) list_+ ]+ , (,) "Settings" $ hcat+ [ label $ return "Create range"+ , checkbox range+ ]+ ]+ where+ list = toEqRef list_++ itemEditor i r = hcat+ [ label $ return $ show (i+1) ++ "."+ , entryShow $ _1 `lensMap` r+ , checkbox $ _2 `lensMap` r+ , button_ (return "Del") (return True) $ modRef list $ \xs -> take i xs ++ drop (i+1) xs+ , button_ (return "Copy") (return True) $ modRef list $ \xs -> take (i+1) xs ++ drop i xs+ ]++ safeList = lens id (const $ take maxi) `lensMap` list++ sel = liftM (filter snd) $ readRef list++ len = readRef range >>= \r -> ll r `lensMap` safeList+ ll :: Bool -> Lens' [(a, Bool)] Int+ ll r = lens length extendList where+ extendList xs n = take n $ (reverse . drop 1 . reverse) xs +++ (uncurry zip . (iterate (+ if r then 1 else 0) *** repeat)) (head $ reverse xs ++ [def])++ mapSel f (x, y) = (if y then f x else x, y)++ (f *** g) (a, b) = (f a, g b)++listEditor :: MonadRegister m => a -> [Ref m a -> Widget m] -> Ref m [a] -> Widget m+listEditor def (ed: eds) r = do+ q <- extRef r listLens (False, (def, []))+ cell (liftM fst $ readRef q) $ \b -> case b of+ False -> empty+ True -> vcat + [ ed $ _2 . _1 `lensMap` q+ , listEditor def eds $ _2 . _2 `lensMap` q+ ]+++
+ lgtkdemo/LGtk/Demos/Main.hs view
@@ -0,0 +1,439 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+module LGtk.Demos.Main+ ( main+ ) where++import Numeric+import Data.Maybe (isJust)+import Control.Lens hiding ((#))+import Control.Monad+import Diagrams.Prelude hiding (vcat, hcat, interval, tri)++import LGtk++import LGtk.Demos.Tri+import LGtk.Demos.IntListEditor+import LGtk.Demos.TEditor+import LGtk.Demos.Maze++main :: IO ()+main = runWidget mainWidget++mainWidget = notebook+ [ (,) "Simple" $ notebook++-- , (,) "Hello" $ label $ return "Hello World!"++ [ (,) "Counters" $ notebook++ [ (,) "Unbounded" $ do+ c <- newEqRef (0 :: Int)+ vcat+ [ label $ liftM show $ readRef c+ , hcat+ [ smartButton (return "+1") c (+1)+ , smartButton (return "-1") c (+(-1))+ ]+ ]++ , (,) "1..3" $ do+ c <- newEqRef (1 :: Int)+ vcat+ [ label $ liftM show $ readRef c+ , hcat+ [ smartButton (return "+1") c $ min 3 . (+1)+ , smartButton (return "-1") c $ max 1 . (+(-1))+ ]+ ]++ , (,) "a..b" $ do+ ab <- newRef (1 :: Int, 3)+ let (a, b) = interval ab+ c <- counter 0 ab+ vcat+ [ label $ liftM show $ readRef c+ , hcat+ [ smartButton (return "+1") c (+1)+ , smartButton (return "-1") c (+(-1))+ ]+ , hcat [ label $ return "min", entryShow a ]+ , hcat [ label $ return "max", entryShow b ]+ ]++ ]++{-+ , (,) "Buttons" $ do+ x <- newRef (0 :: Int)+ let is = [0 :: Double, 0.5, 1]+ colorlist = tail $ liftM3 sRGB is is is+ f n = colorlist !! (n `mod` length colorlist)+ button__ (return "Push") (return True) (liftM f $ readRef x) $ modRef x (+1)++ , (,) "Tabs" $ notebook++ [ (,) "TabSwitch" $ do+ x <- newRef "a"+ let w = vcat [ label $ readRef x, entry x ]+ notebook+ [ (,) "T1" w+ , (,) "T2" w+ ]++ ]+-}++ , (,) "Tri" tri++ , (,) "T-Editor" $ notebook++ [ (,) "Version 1" $ do+ t <- newRef $ iterate (Node Leaf) Leaf !! 10+ hcat+ [ canvas 200 200 20 (const $ return ()) Nothing (readRef t) $+ \x -> tPic 0 x # value () # lw 0.05 # translate (r2 (0,10))+ , tEditor3 t+ ]++ , (,) "Version 2" tEditor1+ ]++ , (,) "Notebook" $ notebook++ [ (,) "Version 2" $ do+ buttons <- newRef ("",[])+ let ctrl = entry $ lens fst (\(_,xs) x -> ("",x:xs)) `lensMap` buttons+ h b = do+ q <- extRef b listLens (False, ("", []))+ cell (liftM fst $ readRef q) $ \bb -> case bb of+ False -> empty+ _ -> do+ vcat $ reverse+ [ h $ _2 . _2 `lensMap` q+ , hcat+ [ button (return "Del") $ return $ Just $ modRef b tail+ , label $ readRef $ _2 . _1 `lensMap` q+ ]+ ]+ vcat $ [ctrl, h $ _2 `lensMap` buttons]++ , (,) "Version 1" $ do+ buttons <- newRef ("",[])+ let h i b = hcat+ [ label $ return b+ , button (return "Del") $ return $ Just $ modRef (_2 `lensMap` buttons) $ \l -> take i l ++ drop (i+1) l+ ]+ set (a,xs) x+ | a /= x = ("",x:xs)+ | otherwise = (a,xs)+ vcat+ [ entry $ lens fst set `lensMap` buttons+ , cell (liftM snd $ readRef buttons) $ vcat . zipWith h [0..]+ ]++ ]++ ]++ , (,) "Canvas" $ notebook++ [ (,) "NotReactive" $ notebook++ [ (,) "Dynamic" $ do++ r <- newRef (3 :: Double)+ vcat+ [ canvas 200 200 12 (const $ return ()) Nothing (readRef r) $+ \x -> circle x # lw 0.05 # fc blue # value ()+ , hcat+ [ hscale 0.1 5 0.05 r+ , label (liftM (("radius: " ++) . ($ "") . showFFloat (Just 2)) $ readRef r)+ ]+ ]++ , (,) "Animation" $ do++ fps <- newRef (50 :: Double)+ speed <- newRef (1 :: Double)+ phase <- newRef (0 :: Double)+ t <- newRef 0+ _ <- onChangeSimple (readRef phase) $ \x -> do+ s <- readRef speed+ f <- readRef fps+ asyncWrite (round $ 1000000 / f) $ writeRef phase (x + 2 * pi * s / f)+ vcat+ [ canvas 200 200 10 (const $ return ()) Nothing (liftM2 (,) (readRef t) (readRef phase)) $+ \(t,x) -> (case t of+ 0 -> circle (2 + 1.5*sin x)+ 1 -> circle 1 # translate (r2 (3,0)) # rotate ((-x) @@ rad)+ 2 -> rect 6 6 # rotate ((-x) @@ rad)+ 3 -> mconcat [circle (i'/10) # translate (r2 (i'/3, 0) # rotate ((i') @@ rad)) | i<-[1 :: Int ..10], let i' = fromIntegral i] # rotate ((-x) @@ rad)+ 4 -> mconcat [circle (i'/10) # translate (r2 (i'/3, 0) # rotate ((x/i') @@ rad)) | i<-[1 :: Int ..10], let i' = fromIntegral i]+ ) # lw 0.05 # fc blue # value ()+ , combobox ["Pulse","Rotate","Rotate2","Spiral","Spiral2"] t+ , hcat+ [ hscale 0.1 5 0.1 speed+ , label (liftM (("freq: " ++) . ($ "") . showFFloat (Just 2)) $ readRef speed)+ ]+ , hcat+ [ hscale 1 100 1 fps+ , label (liftM (("fps: " ++) . ($ "") . showFFloat (Just 2)) $ readRef fps)+ ]+ ]++ ]++ , (,) "Reactive" $ notebook++ [ (,) "ColorChange" $ do+ phase <- newRef (0 :: Double)+ col <- newRef True+ _ <- onChangeSimple (readRef phase) $ \x -> do+ let s = 0.5 :: Double+ let f = 50 :: Double+ asyncWrite (round $ 1000000 / f) $ writeRef phase (x + 2 * pi * s / f)+ let handler (Click (MousePos _ l), _) = when (not $ null l) $ modRef col not+ handler _ = return ()+ vcat+ [ canvas 200 200 10 handler Nothing (liftM2 (,) (readRef col) (readRef phase)) $+ \(c,x) -> circle 1 # translate (r2 (3,0)) # rotate ((-x) @@ rad) # lw 0.05 # fc (if c then blue else red) # value [()]+ , label $ return "Click on the circle to change color."+ ]++ , (,) "Enlarge" $ do+ phase <- newRef (0 :: Double)+ col <- newRef 1+ _ <- onChangeSimple (readRef phase) $ \x -> do+ let s = 0.5 :: Double+ let f = 50 :: Double+ asyncWrite (round $ 1000000 / f) $ do+ writeRef phase (x + 2 * pi * s / f)+ modRef col $ max 1 . (+(- 5/f))+ let handler (Click (MousePos _ l), _) = when (not $ null l) $ modRef col (+1)+ handler _ = return ()+ vcat+ [ canvas 200 200 10 handler Nothing (liftM2 (,) (readRef col) (readRef phase)) $+ \(c,x) -> circle c # translate (r2 (3,0)) # rotate ((-x) @@ rad) # lw 0.05 # fc blue # value [()]+ , label $ return "Click on the circle to temporarily enlarge it."+ ]++ , (,) "Chooser" $ do+ i <- newRef (0 :: Int, 0 :: Rational)+ let i1 = _1 `lensMap` i+ i2 = _2 `lensMap` i+ _ <- onChangeSimple (readRef i) $ \(i,d) -> do+ let dd = fromIntegral i - d+ if dd == 0+ then return ()+ else do+ let s = 2 :: Rational+ let f = 25 :: Rational+ asyncWrite (round $ 1000000 / f) $ do+ writeRef i2 $ d + signum dd * min (abs dd) (s / f)+ let keyh (SimpleKey Key'Left) = modRef i1 pred >> return True+ keyh (SimpleKey Key'Right) = modRef i1 succ >> return True+ keyh _ = return False+ vcat+ [ canvas 200 200 10 (const $ return ()) (Just keyh) (readRef i2) $+ \d -> text "12345" # translate (r2 (realToFrac d, 0)) # scale 2 # value ()+ , label $ liftM show $ readRef i1+ ]++ ]++ , (,) "InCanvas" $ notebook++ [ (,) "Widgets" $ inCanvasExample++ , (,) "Recursive" $ inCanvas 800 600 30 mainWidget++ ]++ ]++ , (,) "System" $ notebook++ {-+ , (,) "Accumulator" $ do+ x <- newRef (0 :: Integer)+ y <- onChangeAcc (readRef x) 0 (const 0) $ \x _ y -> Left $ return $ x+y+ hcat+ [ entryShow x+ , label $ liftM show y+ ]+ -}+ [ (,) "Async" $ do+ ready <- newRef True+ delay <- newRef (1.0 :: Double)+ _ <- onChange (readRef ready) $ \b -> return $ case b of+ True -> return ()+ False -> do+ d <- readRef delay+ asyncWrite (ceiling $ 1000000 * d) $ writeRef ready True+ vcat+ [ hcat [ entryShow delay, label $ return "sec" ]+ , button_ (readRef delay >>= \d -> return $ "Start " ++ show d ++ " sec computation")+ (readRef ready)+ (writeRef ready False)+ , label $ liftM (\b -> if b then "Ready." else "Computing...") $ readRef ready+ ]++ , (,) "Timer" $ do+ t <- newRef (0 :: Int)+ _ <- onChange (readRef t) $ \ti -> return $ asyncWrite 1000000 $ writeRef t $ 1 + ti+ vcat+ [ label $ liftM show $ readRef t+ ]++ , (,) "System" $ notebook++ [ (,) "Args" $ getArgs >>= \args -> label $ return $ unlines args++ , (,) "ProgName" $ getProgName >>= \args -> label $ return args++ , (,) "Env" $ do+ v <- newRef "HOME"+ lv <- newRef ""+ _ <- onChange (readRef v) $ \s -> return $+ postponeModification . writeRef lv =<< liftM (maybe "Not in env." show) (lookupEnv s)+ vcat+ [ entry v+ , label $ readRef lv+ ]++ , (,) "Std I/O" $ let+ put = do+ x <- newRef Nothing+ _ <- onChange (readRef x) $ return . maybe (return ()) putStrLn_+ hcat + [ label $ return "putStrLn"+ , entry $ iso (maybe "" id) Just `lensMap` x+ ]+ get = do+ ready <- newRef $ Just ""+ _ <- onChange (liftM isJust $ readRef ready) $ \b -> + return $ when (not b) $ getLine_ $ writeRef ready . Just+ hcat + [ button_ (return "getLine") (liftM isJust $ readRef ready) $ writeRef ready Nothing+ , label $ liftM (maybe "<<<waiting for input>>>" id) $ readRef ready+ ]+ in vcat [ put, put, put, get, get, get ]+ ]+ ]++ , (,) "Complex" $ notebook++ [ (,) "ListEditor" $ do+ state <- fileRef "intListEditorState.txt"+ list <- extRef (justLens "" `lensMap` state) showLens []+ settings <- fileRef "intListEditorSettings.txt"+ range <- extRef (justLens "" `lensMap` settings) showLens True+ intListEditor (0 :: Integer, True) 15 list range++ , (,) "Maze" $ mazeGame++ ]++{-+ , (,) "Csaba" $ notebook++ [ (,) "#1" $ do+ name <- newRef "None"+ buttons <- newRef []+ let ctrl = hcat+ [ label $ readRef name+ , button (return "Add") $ return $ Just $ do+ l <- readRef buttons+ let n = "Button #" ++ (show . length $ l)+ writeRef buttons $ n:l+ ]+ f n = vcat $ map g n + g n = button (return n) (return . Just $ writeRef name n)+ vcat $ [ctrl, cell (readRef buttons) f]++ , (,) "#2" $ do+ name <- newRef "None"+ buttons <- newRef []+ let ctrl = hcat+ [ label $ readRef name+ , button (return "Add") $ return $ Just $ do+ l <- readRef buttons+ let n = "Button #" ++ (show . length $ l)+ writeRef buttons $ l ++ [n]+ ]+ h b = do+ q <- extRef b listLens (False, ("", []))+ cell (liftM fst $ readRef q) $ \b -> case b of+ False -> empty+ _ -> do+ na <- readRef $ _2 . _1 `lensMap` q+ vcat $ reverse+ [ h $ _2 . _2 `lensMap` q+ , hcat [ button (return na) $ return $ Just $ writeRef name na, entry $ _2 . _1 `lensMap` q ]+ ]+ vcat $ [ctrl, h buttons]++ ]+-} + ]++tPic :: Int -> T -> Dia Any+tPic _ Leaf = circle 0.5 # fc blue+tPic i (Node a b) = tPic (i+1) a # translate (r2 (-w,-2))+ <> tPic (i+1) b # translate (r2 (w,-1.8))+ <> fromVertices [p2 (-w, -2), p2 (0,0), p2 (w,-1.8)]+ where w = 3 * 0.7 ^ i++justLens :: a -> Lens' (Maybe a) a+justLens a = lens (maybe a id) (flip $ const . Just)++counter :: forall m a . (MonadRegister m, Ord a) => a -> Ref m (a, a) -> m (EqRefSimple (BaseRef m) a)+counter x ab = do+ c <- extRef ab (fix . _2) (x, (x, x))+ return $ fix . _1 `lensMap` toEqRef c+ where+ fix :: Lens' (a, (a,a)) (a, (a,a))+ fix = lens id $ \_ (x, ab@(a, b)) -> (min b $ max a x, ab)++interval :: (RefClass r, Ord a) => RefSimple r (a, a) -> (RefSimple r a, RefSimple r a)+interval ab = (lens fst set1 `lensMap` ab, lens snd set2 `lensMap` ab) where+ set1 (_, b) a = (min b a, b)+ set2 (a, _) b = (a, max a b)+++----------------------------------------------------------------------------++inCanvasExample = do+ t <- newRef $ iterate (Node Leaf) Leaf !! 5+ i <- newRef (0 :: Int)+ j <- newRef 0+ s <- newRef "x"+ s' <- newRef "y"+ let x = vcat+ [ hcat+ [ vcat+ [ hcat+ [ label $ readRef i >>= \i -> return $ show i ++ "hello"+ , button_ (return "+1") (return True) $ modRef i (+1)+ ]+ , hcat+ [ entry s+ , entry s+ ]+ , hcat+ [ entry s'+ , entry s'+ ]+ ]+ , combobox ["Hello","World","!"] j+ ]+ , tEditor3 t+ ]++ hcat [ inCanvas 200 300 15 $ vcat [x, inCanvas 100 100 15 x], x]+++
+ lgtkdemo/LGtk/Demos/Maze.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+module LGtk.Demos.Maze where++import Control.Monad+import Control.Monad.State+import Data.List+import Data.Array+import qualified Data.Set as S+import System.Random+import Diagrams.Prelude hiding (vcat, hcat, Point, Start)++import Control.Lens hiding ((#))+import LGtk++import LGtk.Demos.Maze.Types+import qualified LGtk.Demos.MazeGen as Maze1+import qualified LGtk.Demos.Maze.Maze as Maze2++---------------------------------- Game state++data GameState+ = Start+ | Explore Point+ | Fail+ | Success++instance Show GameState where+ show Success = "Congratulation!"+ show Fail = "Failure, try again!"+ show Start = "Move the pointer to the filled circle"+ show (Explore _) = "Reach the bottom left corner"++------------------------ maze drawing++drawMaze :: (Maze, S.Set Point, Maybe Point) -> Dia [Point]+drawMaze (maze, hi, pos) =+ ( mconcat (map drawCell $ assocs maze) # centerXY+ <> rect (fromIntegral $ x2-x1+1) (fromIntegral $ y2-y1+1) # lw 0.005 # fc (sRGB 0.95 0.95 0.95) # value []+ ) # scale (1 / fromIntegral (max (x2-x1+1) (y2-y1+1)))+ where+ drawCell (p@(i,j), C cs) =+ ( (if b then mconcat (map drawWall $ complement cs) # lw 0.005 # value [] else mempty)+ <> (if Just p == pos then circle 0.35 # lw 0.003 # fc blue # value [] else mempty)+ <> (if p == q2 then circle 0.35 # lw 0.003 # value [] else mempty)+ <> (if p == q1 then circle 0.35 # lw 0.003 # value [] else mempty)+ <> rect 1 1 # lw 0 # (if b then fc yellow else id) # value [p]+ ) # translate (r2 (fromIntegral i, fromIntegral j))+ where b = S.member p hi++ drawWall E = fromVertices [p2 (-d, d), p2 (d, d)]+ drawWall S = fromVertices [p2 (d, -d), p2 (d, d)]+ drawWall W = fromVertices [p2 (-d, -d), p2 (d, -d)]+ drawWall N = fromVertices [p2 (-d, -d), p2 (-d, d)]++ d = 0.5++ (q1@(x1,y1), q2@(x2,y2)) = bounds maze++complement :: [Cardinal] -> [Cardinal]+complement = f [N,E,S,W] . sort+ where+ f (x:xs) (y:ys) | x == y = f xs ys+ f (x:xs) ys = x: f xs ys+ f [] _ = []++----------------------- game logic++-- | check whether a move does not hit the wall+isOk :: Maze -> Point -> Point -> Bool+isOk maze p q = p == q || maybe False (`elem` unC (maze ! p)) (dir p q)+ where+ unC (C xs) = xs++ dir (a,b) (c,d)+ | a == c && b == d + 1 = Just W+ | a == c && b == d - 1 = Just E+ | a == c + 1 && b == d = Just N+ | a == c - 1 && b == d = Just S+ | otherwise = Nothing++checkBounds ((a,b),(c,d)) (e,f)+ | a <= e && e <= c && b <= f && f <= d = Just (e,f)+ | otherwise = Nothing++gameLogic b maze p (s, st) = case st of+ Start | p == snd (bounds maze) -> commit+ Explore q+ | isOk maze q p || b && S.member p s -> commit+ | not b -> (s, Fail)+ _ -> (s, st)+ where+ commit = (S.insert p s, if p == fst (bounds maze) then Success else Explore p)++------------------------ GUI++mazeGame :: forall m . MonadRegister m => Widget m+mazeGame = do+ forgiving <- newRef False+ let init = (0,(4,4))+ dim_ <- newRef init+ let dim = _2 `lensMap` dim_+ mazekind = _1 `lensMap` dim_+ dimX = (_2 . iso id (max 1 . min 40)) `lensMap` toEqRef dim+ dimY = (_1 . iso id (max 1 . min 40)) `lensMap` toEqRef dim+ genMaze (0, d) = Maze1.genMaze d+ genMaze (1, d) = Maze2.genMaze d+ maze_ <- extRef_ dim_ (runState (genMaze init) (mkStdGen 323401)) $ \d (_, s) -> runState (genMaze d) s+ r <- extRef_ maze_ (S.empty, Start) $ \_ _ -> (S.empty, Start)++ let handler (MoveTo (MousePos _ [p]), _) = domove p+ handler _ = return ()++ domove p = do+ (maze, _) <- readRef maze_+ b <- readRef forgiving+ modRef r $ gameLogic b maze p++ move f = do+ (maze, _) <- readRef maze_+ (_, st) <- readRef r+ let m = case st of+ Start -> Just $ snd $ bounds maze+ Explore p -> checkBounds (bounds maze) $ f p+ _ -> Nothing+ maybe (return True) ((>> return True) . domove) m++ key (SimpleKey Key'Left) = move $ \(x,y)->(x-1,y)+ key (SimpleKey Key'Right) = move $ \(x,y)->(x+1,y)+ key (SimpleKey Key'Up) = move $ \(x,y)->(x,y+1)+ key (SimpleKey Key'Down) = move $ \(x,y)->(x,y-1)+ key _ = return False++ pos maze Start = Just $ snd $ bounds maze+ pos maze Success = Just $ fst $ bounds maze+ pos _ (Explore p) = Just p+ pos _ _ = Nothing++ vcat+ [ hcat+ [ canvas 400 400 1 handler (Just key) (liftM2 (\(m,_) (s, st) -> (m,s, pos m st)) (readRef maze_) (readRef r)) drawMaze++ , vcat+ [ hcat+ [ checkbox forgiving+ , label $ return "forgiving mode"+ ]+ , combobox ["cdsmith's", "Mihai Maruseac's"] mazekind+ , label $ return "maze generator"+ ]+ ]++ , label $ liftM (show . snd) $ readRef r+ , hcat+ [ button (return "Try again") $ return $ Just $ modRef maze_ id+ , button (return "New maze") $ return $ Just $ modRef dim id+ ]+ , hcat+ [ entryShow dimX+ , smartButton (return "+1") dimX succ+ , smartButton (return "-1") dimX pred+ , label $ return "width"+ ]+ , hcat+ [ entryShow dimY+ , smartButton (return "+1") dimY succ+ , smartButton (return "-1") dimY pred+ , label $ return "height"+ ]+ ]++----------------------------- utils++extRef_ :: MonadRegister m => Ref m b -> a -> (b -> a -> a) -> m (Ref m a)+extRef_ r def f = do+ r0 <- readRef r+ v <- extRef r (lens fst set) (r0, def)+ return $ _2 `lensMap` v+ where+ set (_, y) x = (x, f x y)++
+ lgtkdemo/LGtk/Demos/Maze/Maze.hs view
@@ -0,0 +1,89 @@+module LGtk.Demos.Maze.Maze (genMaze)+where++import Control.Arrow (first, second)+import Control.Monad.State (state, State)+import Data.Array.ST (runSTArray, newListArray, readArray, writeArray)+import System.Random (StdGen, randomR)++import LGtk.Demos.Maze.Types++{-+Generates the entire maze.+-}+genMaze :: Size -> State StdGen Maze+genMaze s@(sx, sy) = do+ (ews, ups) <- gMP s+ return $ build sx sy ews ups++{-+Builds the maze using Sidewinder's algorithm.+-}+build :: Length -> Length -> [Point] -> [Point] -> Maze+build sx sy ews ups = runSTArray $ do+ m <- newListArray ((1, 1), (sy, sx)) $ repeat $ C [E, W]+ -- 1. Block eastern walls (including first row's end)+ mapM_ (blockCell m E) $ (sx, 1) : ews+ -- 2. Block western walls of corridors+ mapM_ (blockCell m W . first (+1)) $ filter (fst . first (/= sx)) ews+ -- 3. Block starts of rows.+ mapM_ (blockCell m W . (\y -> (1, y))) [1 .. sy]+ -- 4. Open northwards.+ mapM_ (openCell m N) ups+ -- 5. Open southwards+ mapM_ (openCell m S . second (subtract 1)) ups+ return m++{-+Generates all the important points in the maze. Receives size of maze and+returns a tuple with cells where the eastern corridor ends and where the+northwards openings are placed.+-}+gMP :: Size -> State StdGen ([Point], [Point])+gMP (sx, sy) = do+ points <- mapM (gRP 0 sx) [2..sy]+ return $ foldl (\(x, y) (a, b) -> (x ++ a, y ++ b)) ([], []) points++{-+Generates the important point for a row. Receives current position, length of+row and row order and returns a tuple containing a list of cells where the+eastern corridor should end and a list of cells where northwards openings+should be placed.+-}+gRP :: Coord -> Length -> Coord -> State StdGen ([Point], [Point])+gRP c sx y+ | sx <= 0 = return ([], [])+ | otherwise = do+ len <- state $ randomR (1, sx)+ up <- state $ randomR (1, len)+ (rx, ry) <- gRP (c + len) (sx - len) y+ return ((len + c, y):rx, (up + c, y):ry)++{-+Block one cell from the maze, represented as an array.+-}+-- blockCell :: Data.Array.MArray Size Cell -> Cardinal -> Size -> m ()+blockCell m d (x, y) = do+ e <- readArray m (y, x)+ writeArray m (y, x) $ block e d++{-+Open one cell from the maze, represented as an array.+-}+-- openCell :: (MArray a Cell m) => a Size Cell -> Cardinal -> Size -> m ()+openCell m d (x, y) = do+ e <- readArray m (y, x)+ writeArray m (y, x) $ open e d++{-+Block a cell from one direction.+-}+block :: Cell -> Cardinal -> Cell+block (C l) x = C $ filter (/= x) l++{-+Open a cell to one direction.+-}+open :: Cell -> Cardinal -> Cell+open (C l) x = C $ if x `elem` l then l else x : l+
+ lgtkdemo/LGtk/Demos/Maze/Types.hs view
@@ -0,0 +1,31 @@+module LGtk.Demos.Maze.Types+where++import Data.Array (Array)+import Data.Vector (Vector)++{-+Common types are presented in this file.+-}++{- Small typedefs -}+type Length = Int+type Coord = Int+type Size = (Length, Length)+type Point = Size+type Dir = Size+type Time = Int+type Fitness = Int++{- The cardinal directions. -}+data Cardinal = N | E | S | W deriving (Eq, Show, Read, Ord, Enum)++{- A cell. The list contains the openings. -}+newtype Cell = C [Cardinal] deriving (Eq, Show, Read)++{- Simple type for maze. -}+type Maze = Array Size Cell++{- A plan is a vector of directions to go, at each time step. -}+type Plan = Vector Cardinal+
+ lgtkdemo/LGtk/Demos/MazeGen.hs view
@@ -0,0 +1,63 @@+module LGtk.Demos.MazeGen+ ( genMaze+ ) where++import Data.List+import Data.Array.IArray+import System.Random+import Data.Equivalence.Persistent+import System.Random.Shuffle++import Control.Monad.State+import LGtk.Demos.Maze.Types hiding (Cell)+import qualified LGtk.Demos.Maze.Types as M++------------ copied from http://cdsmith.wordpress.com/2011/06/06/mazes-in-haskell-my-version/ on 9 May, 2014++-- Vertical walls are to the right of their cell (so the x component+-- must be less than width - 1), and horizontal walls are to the top+-- of their cell (so the y component must be less than height - 1).++type Cell = (Int, Int)+data Wall = H Cell | V Cell deriving (Eq, Show)++process rooms [] = []+process rooms (H (x,y) : ws)+ | equiv rooms (x,y) (x,y+1) = H (x,y) : process rooms ws+ | otherwise = process (equate (x,y) (x,y+1) rooms) ws+process rooms (V (x,y) : ws)+ | equiv rooms (x,y) (x+1,y) = V (x,y) : process rooms ws+ | otherwise = process (equate (x,y) (x+1,y) rooms) ws++genMaze_ :: RandomGen gen => Int -> Int -> gen -> [Wall]+genMaze_ w h gen = finalWalls+ where allWalls = [ H (x,y) | x <- [0 .. w-1], y <- [0 .. h-2] ]+ ++ [ V (x,y) | x <- [0 .. w-2], y <- [0 .. h-1] ]+ startRooms = emptyEquivalence ((0,0), (w-1, h-1))+ startWalls = shuffle' allWalls (length allWalls) gen+ finalWalls = process startRooms startWalls++------------ end of copy++genMaze :: Size -> State StdGen Maze+genMaze (w, h) = state f where+ f s = (tr $ genMaze_ w h s1, s2)+ where+ (s1, s2) = split s++ tr ls = array ((1,1), (w,h)) [ ((i,j), C $ complement $ concatMap (g i j) ls) | i <- [1..w], j<-[1..h]]+ where+ g i j (V (x,y)) | i == x + 1 && j == y + 1 = [S]+ g i j (V (x,y)) | i == x + 2 && j == y + 1 = [N]+ g i j (H (x,y)) | i == x + 1 && j == y + 1 = [E]+ g i j (H (x,y)) | i == x + 1 && j == y + 2 = [W]+ g _ _ _ = []+++complement :: [Cardinal] -> [Cardinal]+complement = f [N,E,S,W] . sort+ where+ f (x:xs) (y:ys) | x == y = f xs ys+ f (x:xs) ys = x: f xs ys+ f [] _ = []+
+ lgtkdemo/LGtk/Demos/TEditor.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+module LGtk.Demos.TEditor where++import Control.Lens hiding (Cons)+import Control.Monad+import LGtk+import LGtk.ADTEditor++-- | Binary tree shapes+data T+ = Leaf+ | Node T T+ deriving (Eq, Show)++-- | Lens for @T@+tLens :: Lens' (Bool, (T, T)) T+tLens = lens get set where+ get (False, _) = Leaf+ get (True, (l, r)) = Node l r+ set (_, x) Leaf = (False, x)+ set _ (Node l r) = (True, (l, r))++-- | @ADTLens@ instance for @T@+instance ADTLens T where+ type ADTEls T = Cons T (Cons T Nil)+ adtLens = ([("Leaf",[]),("Node",[0,1])], ElemsCons Leaf (ElemsCons Leaf ElemsNil), Lens_ $ lens get set) where+ get :: (Int, Elems (ADTEls T)) -> T+ get (0, _) = Leaf+ get (1, ElemsCons l (ElemsCons r ElemsNil)) = Node l r+ set :: (Int, Elems (ADTEls T)) -> T -> (Int, Elems (ADTEls T))+ set (_, x) Leaf = (0, x)+ set _ (Node l r) = (1, ElemsCons l (ElemsCons r ElemsNil))++-- | @T@ editor with comboboxes, as an ADTEditor+tEditor1 :: MonadRegister m => Widget m+tEditor1 = join $ newRef Leaf >>= adtEditor++-- | @T@ editor with checkboxes, given directly+tEditor3 :: MonadRegister m => Ref m T -> Widget m+tEditor3 r = do+ q <- extRef r tLens (False, (Leaf, Leaf))+ hcat+ [ checkbox $ _1 `lensMap` q+ , cell (liftM fst $ readRef q) $ \b -> case b of+ False -> empty+ True -> vcat+ [ tEditor3 $ _2 . _1 `lensMap` q+ , tEditor3 $ _2 . _2 `lensMap` q+ ]+ ]++
+ lgtkdemo/LGtk/Demos/Tri.hs view
@@ -0,0 +1,39 @@+{- |+An editor for integers x, y, z such that x + y = z always hold and+the last edited value change.+-}+module LGtk.Demos.Tri where++import Control.Lens+import LGtk++-- | Information pieces: what is known?+data S = X Int | Y Int | XY Int++-- | Getter+getX, getY, getXY :: [S] -> Int+getX s = head $ [x | X x <- s] ++ [getXY s - getY s]+getY s = head $ [x | Y x <- s] ++ [getXY s - getX s]+getXY s = head $ [x | XY x <- s] ++ [getX s + getY s]++-- | Setter+setX, setY, setXY :: [S] -> Int -> [S]+setX s x = take 2 $ X x : filter (\x-> case x of X _ -> False; _ -> True) s+setY s x = take 2 $ Y x : filter (\x-> case x of Y _ -> False; _ -> True) s+setXY s x = take 2 $ XY x : filter (\x-> case x of XY _ -> False; _ -> True) s++-- | The editor+tri :: MonadRegister m => Widget m+tri = do+ s <- newRef [X 0, Y 0]+ vcat+ [ hcat [entryShow $ lens getX setX `lensMap` s, label $ return "x"]+ , hcat [entryShow $ lens getY setY `lensMap` s, label $ return "y"]+ , hcat [entryShow $ lens getXY setXY `lensMap` s, label $ return "x + y"]+ ]++++++
+ lgtkdemo/Main.hs view
@@ -0,0 +1,5 @@++import qualified LGtk.Demos.Main as LGtk ( main )++main :: IO ()+main = LGtk.main
− src/Control/Monad/EffRef.hs
@@ -1,298 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-module Control.Monad.EffRef where--import Control.Applicative-import Control.Concurrent-import Control.Exception (evaluate)-import Control.Monad-import Control.Monad.RWS-import Control.Monad.Writer--import Control.Monad.State-import Control.Monad.Trans-import Control.Monad.Trans.Identity-import System.Directory-import System.FSNotify-import Filesystem.Path hiding (FilePath)-import Filesystem.Path.CurrentOS hiding (FilePath)-import Control.Monad.Operational--import Control.Monad.Restricted-import Control.Monad.ExtRef-import Control.Monad.ExtRef.Pure---- | Monad for dynamic actions-class ExtRef m => EffRef m where-- type CallbackM m :: * -> *-- type EffectM m :: * -> *-- liftEffectM' :: Morph (EffectM m) m-- {- |- Let @r@ be an effectless action (@ReadRef@ guarantees this).-- @(onChange init r fmm)@ has the following effect:-- Whenever the value of @r@ changes (with respect to the given equality),- @fmm@ is called with the new value @a@.- The value of the @(fmm a)@ action is memoized,- but the memoized value is run again and again.-- The boolean parameter @init@ tells whether the action should- be run in the beginning or not.-- For example, let @(k :: a -> m b)@ and @(h :: b -> m ())@,- and suppose that @r@ will have values @a1@, @a2@, @a3@ = @a1@, @a4@ = @a2@.-- @onChange True r $ \\a -> k a >>= return . h@-- has the effect-- @k a1 >>= \\b1 -> h b1 >> k a2 >>= \\b2 -> h b2 >> h b1 >> h b2@-- and-- @onChange False r $ \\a -> k a >>= return . h@-- has the effect-- @k a2 >>= \\b2 -> h b2 >> k a1 >>= \\b1 -> h b1 >> h b2@- -}- onChange :: Eq a => Bool -> ReadRef m a -> (a -> m (m ())) -> m ()-- toReceive :: Eq a => (a -> WriteRef m ()) -> (Command -> EffectM m ()) -> m (a -> CallbackM m ())--data Command = Kill | Block | Unblock deriving (Eq, Ord, Show)--rEffect :: (EffRef m, Eq a) => Bool -> ReadRef m a -> (a -> EffectM m ()) -> m ()-rEffect init r f = onChange init r $ return . liftEffectM' . f---type SyntEffRef n m x = Program (EffRefI n m x)-data EffRefI n m x a where- SyntLiftEffect :: m a -> EffRefI n m x a- SyntLiftExtRef :: SyntExtRef x a -> EffRefI n m x a- SyntOnChange :: Eq a => Bool -> SyntRefReader x a -> (a -> SyntEffRef n m x (SyntEffRef n m x ())) -> EffRefI n m x ()- SyntReceive :: Eq a => (a -> SyntRefState x ()) -> (Command -> m ()) -> EffRefI n m x (a -> n ())--instance ExtRef (SyntEffRef n m x) where- type Ref (SyntEffRef n m x) = SyntRef x- liftWriteRef w = singleton $ SyntLiftExtRef $ liftWriteRef w- extRef r l a = singleton $ SyntLiftExtRef $ extRef r l a- newRef a = singleton $ SyntLiftExtRef $ newRef a--liftEffectM = singleton . SyntLiftEffect--instance EffRef (SyntEffRef n m x) where- type EffectM (SyntEffRef n m x) = m- type CallbackM (SyntEffRef n m x) = n- liftEffectM' = singleton . SyntLiftEffect- onChange b r f = singleton $ SyntOnChange b r f- toReceive f g = singleton $ SyntReceive f g---type CO m = WriterT (MonadMonoid m, Command -> MonadMonoid m) m--evalRegister' :: (NewRef m) => (StateT LSt m () -> m ()) -> SyntEffRef m (StateT LSt m) (Lens_ LSt) a -> CO (StateT LSt m) a-evalRegister' ff = eval . view- where- eval (Return x) = return x- eval (SyntLiftEffect m :>>= k) = lift m >>= evalRegister' ff . k- eval (SyntLiftExtRef m :>>= k) = lift (runExtRef m) >>= evalRegister' ff . k- eval (SyntReceive f g :>>= k) = tell (t2 g) >> evalRegister' ff (k $ ff . runExtRef . liftWriteRef . f)- eval (SyntOnChange b r f :>>= k) = toSend__ b (runExtRef $ liftReadRef r) (liftM (evalRegister' ff) . evalRegister' ff . f) >>= evalRegister' ff . k--newRef'' x = liftM (\r -> MorphD $ \m -> StateT $ \s -> runMorphD r $ mapStateT (\k -> runStateT k s >>= \((x, w), s) -> return ((x, s), w)) m) $ newRef' x----toSend__ :: (Eq b, NewRef m) => Bool -> m b -> (b -> Register' m (Register' m ())) -> Register' m ()-toSend__ init rb fb = do- b <- lift rb- v <- case init of- False -> return $ Left b- True -> lift $ do- (c, (s1, ureg1)) <- runWriterT (fb b)- (s2, ureg2) <- execWriterT c- runMonadMonoid $ s1 `mappend` s2- return $ Right [(b, (c, s1, s2, ureg1, ureg2))]- memoref <- lift $ lift $ newRef'' v- -- memo table, first item is the newest- tell $ t1 $ do- b <- rb- join $ runMorphD memoref $ StateT $ \memo -> case memo of- Left b' | b' == b -> return (return (), memo)- Right ((b', (_, s1, s2, _, _)): _) | b' == b ->- return (runMonadMonoid $ s1 `mappend` s2, memo)- _ -> do- case memo of- Right ((_, (_, _, _, ureg1, ureg2)): _) ->- runMonadMonoid $ ureg1 Block `mappend` ureg2 Kill- _ -> return ()- (c, (s1, ureg1)) <- case filter ((== b) . fst) $ either (const []) id memo of- ((_, (c, s1, _, ureg1, _)): _) -> do- runMonadMonoid $ ureg1 Unblock- return (c, (s1, ureg1))- _ -> runWriterT (fb b)- (s2, ureg2) <- execWriterT c- let memo' = Right $ (:) (b, (c, s1, s2, ureg1, ureg2)) $ filter ((/= b) . fst) $ either (const []) id memo- return (runMonadMonoid $ s1 `mappend` s2, memo')--t1 m = (MonadMonoid m, mempty)-t2 m = (mempty, MonadMonoid . m)----- | Type class for IO actions.-class (EffRef m, SafeIO m, SafeIO (ReadRef m)) => EffIORef m where--- {- |- @(asyncWrite t f a)@ has the effect of doing @(f a)@ after waiting @t@ milliseconds.-- Note that @(asyncWrite 0 f a)@ acts immediately after the completion of the current computation,- so it is safe, because the effect of @(f a)@ is not interleaved with- the current computation.- Although @(asyncWrite 0)@ is safe, code using it has a bad small.- -}- asyncWrite_ :: Eq a => Int -> (a -> WriteRef m ()) -> a -> m ()-- {- |- @(fileRef path)@ returns a reference which holds the actual contents- of the file accessed by @path@.-- When the value of the reference changes, the file changes.- When the file changes, the value of the reference changes.-- If the reference holds @Nothing@, the file does not exist.- Note that you delete the file by putting @Nothing@ into the reference. -- Implementation note: The references returned by @fileRef@ are not- memoised so currently it is unsafe to call @fileRef@ on the same filepath more than once.- This restriction will be lifted in the future.- -}- fileRef :: FilePath -> m (Ref m (Maybe String))--- {- | Read a line from the standard input device.- @(getLine_ f)@ returns immediately. When the line @s@ is read,- @f s@ is called.- -}- getLine_ :: (String -> WriteRef m ()) -> m ()-- -- | Write a string to the standard output device.- putStr_ :: EffIORef m => String -> m ()---- | @putStrLn_@ === @putStr_ . (++ "\n")@-putStrLn_ :: EffIORef m => String -> m ()-putStrLn_ = putStr_ . (++ "\n")--asyncWrite :: EffIORef m => Int -> (a -> WriteRef m ()) -> a -> m ()-asyncWrite t f a = asyncWrite' t $ f a--asyncWrite' :: EffIORef m => Int -> WriteRef m () -> m ()-asyncWrite' t r = asyncWrite_ t (const r) ()--type SyntEffIORef m x = SyntEffRef m (StateT LSt m) x--instance SafeIO (SyntRefReader x) where-instance SafeIO (SyntEffIORef m x) where--instance EffIORef (SyntEffIORef IO x) where-- asyncWrite_ t r a = do- (u, f) <- liftIO' forkIOs'- x <- toReceive r $ liftIO . u- liftIO' $ f [ threadDelay t, x a ]-- fileRef f = do- ms <- liftIO' r- ref <- newRef ms- v <- liftIO' newEmptyMVar- vman <- liftIO' newEmptyMVar- cf <- liftIO' $ canonicalizePath f -- FIXME: canonicalizePath may fail if the file does not exsist- let- cf' = decodeString cf- g = (== cf')-- h = tryPutMVar v () >> return ()-- filt (Added x _) = g x- filt (Modified x _) = g x- filt (Removed x _) = g x-- act (Added _ _) = putStrLn "added" >> h- act (Modified _ _) = putStrLn "mod" >> h- act (Removed _ _) = putStrLn "rem" >> h-- startm = do- putStrLn " start" - man <- startManager- putMVar vman $ putStrLn " stop" >> stopManager man- watchDir man (directory cf') filt act-- liftIO' startm-- (u, ff) <- liftIO' forkIOs'- re <- toReceive (writeRef ref) $ liftIO . u- liftIO' $ ff $ repeat $ takeMVar v >> r >>= re-- rEffect False (readRef ref) $ \x -> liftIO $ do- join $ takeMVar vman- _ <- tryTakeMVar v- putStrLn " write"- w x- threadDelay 10000- startm- return ref- where- r = do- b <- doesFileExist f- if b then do- xs <- readFile f- _ <- evaluate (length xs)- return (Just xs)- else return Nothing-- w = maybe (doesFileExist f >>= \b -> when b (removeFile f)) (writeFile f)-- getLine_ w = do- (u, f) <- liftIO' forkIOs'- x <- toReceive w $ liftIO . u- liftIO' $ f [ getLine >>= x ] -- TODO- putStr_ s = liftIO' $ putStr s--liftIO__ :: Monad m => m a -> SyntEffIORef m (Lens_ LSt) a-liftIO__ m = singleton $ SyntLiftEffect $ lift m----liftIO' :: EffIORef m => IO a -> m a-liftIO' m = liftEffectM $ liftIO m-----forkIOs' :: IO (Command -> IO (), [IO ()] -> IO ())-forkIOs' = do- x <- newMVar ()- s <- newEmptyMVar- let g = do- readMVar x- is <- takeMVar s- case is of- [] -> return ()- (i:is) -> do- putMVar s is- i- g- f i Kill = killThread i- f _ Block = takeMVar x- f _ Unblock = putMVar x ()-- i <- forkIO g- return (f i, putMVar s)-
− src/Control/Monad/ExtRef.hs
@@ -1,298 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-module Control.Monad.ExtRef where--import Control.Monad-import Control.Monad.Reader-import Control.Monad.Writer-import Control.Monad.State---import Control.Monad.RWS---import Control.Monad.Trans.Identity---import Control.Monad.Operational-import Data.Lens.Common---- | @m@ has a submonad @(RefStateReader m)@ which is isomorphic to 'Reader'.-class (Monad m, Monad (RefStateReader m)) => MonadRefState m where-- {- | Law: @(RefStateReader m)@ === @('Reader' x)@ for some @x@.-- Alternative laws which ensures this isomorphism (@r :: (RefStateReader m a)@ is arbitrary):-- * @(r >> return ())@ === @return ()@-- * @liftM2 (,) r r@ === @liftM (\a -> (a, a)) r@-- See also <http://stackoverflow.com/questions/16123588/what-is-this-special-functor-structure-called>- -}- type RefStateReader m :: * -> *-- -- | @(RefStateReader m)@ is a submonad of @m@- liftRefStateReader :: RefStateReader m a -> m a---- | @RefStateReader (StateT s m) = Reader s@ -instance Monad m => MonadRefState (StateT s m) where- type RefStateReader (StateT s m) = Reader s- liftRefStateReader = gets . runReader---{- |-A reference @(r a)@ is isomorphic to @('Lens' s a)@ for some fixed state @s@.--@r@ === @Lens s@--}-class (MonadRefState (RefState r)) => Reference r where-- {- | @Refmonad r@ === @State s@-- Property derived from the 'MonadRefState' instance:-- @RefReader r@ = @RefStateReader (Refmonad r)@ === @Reader s@- -}- type RefState r :: * -> *-- {- | @readRef@ === @reader . getL@-- Properties derived from the 'MonadRefState' instance:-- @(readRef r >> return ())@ === @return ()@- -}- readRef :: r a -> RefReader r a-- {- | @writeRef r@ === @modify . setL r@-- Properties derived from the set-get, get-set and set-set laws for lenses:-- * @(readRef r >>= writeRef r)@ === @return ()@-- * @(writeRef r a >> readRef r)@ === @return a@-- * @(writeRef r a >> writeRef r a')@ === @writeRef r a'@- -}- writeRef :: r a -> a -> RefState r ()-- {- | Apply a lens on a reference.-- @lensMap@ === @(.)@- -}- lensMap :: Lens' a b -> r a -> r b-- {- | @joinRef@ makes possible to define dynamic references, i.e. references which depends on- values of other references.- It is not possible to create new reference dynamically with @joinRef@; for that, see 'onChange'.-- @joinRef@ === @Lens . join . (runLens .) . runReader@- -}- joinRef :: RefReader r (r a) -> r a-- -- | @unitRef@ === @lens (const ()) (const id)@- unitRef :: r ()--type RefReader m = RefStateReader (RefState m)--infixr 8 `lensMap`----- | @modRef r f@ === @liftRefStateReader (readRef r) >>= writeRef r . f@-modRef :: Reference r => r a -> (a -> a) -> RefState r ()-r `modRef` f = liftRefStateReader (readRef r) >>= writeRef r . f---{- | Monad for reference creation. Reference creation is not a method-of the 'Reference' type class to make possible to-create the same type of references in multiple monads.--@(Extref m) === (StateT s m)@, where 's' is an extendible state.--For basic usage examples, look into the source of @Control.Monad.ExtRef.Pure.Test@.--}-class (Monad m, Reference (Ref m)) => ExtRef m where-- type Ref m :: * -> *-- -- | @'WriteRef' m@ is a submonad of @m@.- liftWriteRef :: WriteRef m a -> m a-- {- | Reference creation by extending the state of an existing reference.-- Suppose that @r@ is a reference and @k@ is a lens.-- Law 1: @extRef@ applies @k@ on @r@ backwards, i.e. - the result of @(extRef r k a0)@ should behaves exactly as @(lensMap k r)@.-- * @(liftM (k .) $ extRef r k a0)@ === @return r@-- Law 2: @extRef@ does not change the value of @r@:-- * @(extRef r k a0 >> readRef r)@ === @(readRef r)@-- Law 3: Proper initialization of newly defined reference with @a0@:-- * @(extRef r k a0 >>= readRef)@ === @(readRef r >>= setL k a0)@- -}- extRef :: Ref m b -> Lens' a b -> a -> m (Ref m a)-- {- | @newRef@ extends the state @s@ in an independent way.-- @newRef@ === @extRef unitRef (lens (const ()) (const id))@- -}- newRef :: a -> m (Ref m a)- newRef = extRef unitRef $ lens (const ()) (flip $ const id)---type WriteRef m = RefState (Ref m)--type ReadRef m = RefReader (Ref m)--{- | @ReadRef@ lifted to the reference creation class.--Note that we do not lift @WriteRef@ to the reference creation class, which a crucial restriction-in the LGtk interface; this is a feature.--}-liftReadRef :: ExtRef m => ReadRef m a -> m a-liftReadRef = liftWriteRef . liftRefStateReader--{- | @readRef@ lifted to the reference creation class.--@readRef'@ === @liftReadRef . readRef@--}-readRef' :: ExtRef m => Ref m a -> m a-readRef' = liftReadRef . readRef--{- | Lazy monadic evaluation.-In case of @y <- memoRead x@, invoking @y@ will invoke @x@ at most once.--Laws:-- * @(memoRead x >> return ())@ === @return ()@-- * @(memoRead x >>= id)@ === @x@-- * @(memoRead x >>= \y -> liftM2 (,) y y)@ === @liftM (\a -> (a, a)) y@-- * @(memoRead x >>= \y -> liftM3 (,) y y y)@ === @liftM (\a -> (a, a, a)) y@-- * ...--}-memoRead :: ExtRef m => m a -> m (m a)-memoRead g = do- s <- newRef Nothing- return $ readRef' s >>= \x -> case x of- Just a -> return a- _ -> g >>= \a -> do- liftWriteRef $ writeRef s $ Just a- return a--memoWrite :: (ExtRef m, Eq b) => (b -> m a) -> m (b -> m a)-memoWrite g = do- s <- newRef Nothing- return $ \b -> readRef' s >>= \x -> case x of- Just (b', a) | b' == b -> return a- _ -> g b >>= \a -> do- liftWriteRef $ writeRef s $ Just (b, a)- return a----- | This instance is used in the implementation, end users do not need it.-instance (ExtRef m, Monoid w) => ExtRef (WriterT w m) where-- type Ref (WriterT w m) = Ref m-- liftWriteRef = lift . liftWriteRef-- extRef x y a = lift $ extRef x y a----- | Undo-redo state transformation.-undoTr- :: ExtRef m =>- (a -> a -> Bool) -- ^ equality on state- -> Ref m a -- ^ reference of state- -> m ( ReadRef m (Maybe (WriteRef m ())) - , ReadRef m (Maybe (WriteRef m ()))- ) -- ^ undo and redo actions-undoTr eq r = do- ku <- extRef r (undoLens eq) ([], [])- let try f = liftM (liftM (writeRef ku) . f) $ readRef ku- return (try undo, try redo)- where- undo (x: xs@(_:_), ys) = Just (xs, x: ys)- undo _ = Nothing-- redo (xs, y: ys) = Just (y: xs, ys)- redo _ = Nothing--undoLens :: (a -> a -> Bool) -> Lens' ([a],[a]) a-undoLens eq = lens get set where- get = head . fst- set (x' : xs, ys) x | eq x x' = (x: xs, ys)- set (xs, _) x = (x : xs, [])---{- | References with inherent equivalence.---}-class Reference r => EqReference r where-- {- | @hasEffect r f@ returns @False@ iff @(modRef m f)@ === @(return ())@.-- @hasEffect@ is correct only if @eqRef@ is applied on a pure reference (a reference which is a pure lens on the hidden state).-- @hasEffect@ makes defining auto-sensitive buttons easier, for example.- -}- hasEffect- :: r a- -> (a -> a)- -> RefReader r Bool---data EqRef_ r a = forall b . Eq b => EqRef_ (r b) (Lens' b a)--{- | References with inherent equivalence.--@EqRef r a@ === @RefReader r (exist b . Eq b => (Lens' b a, r b))@--As a reference, @(m :: EqRef r a)@ behaves as--@joinRef $ liftM (uncurry lensMap) m@--}-newtype EqRef r a = EqRef { runEqRef :: RefReader r (EqRef_ r a) }--{- | @EqRef@ construction.--}-eqRef :: (Reference r, Eq a) => r a -> EqRef r a-eqRef r = EqRef $ return $ EqRef_ r id--newEqRef :: (ExtRef m, Eq a) => a -> m (EqRef (Ref m) a) -newEqRef = liftM eqRef . newRef--{- | An @EqRef@ is a normal reference if we forget about the equality.--@toRef m@ === @joinRef $ liftM (uncurry lensMap) m@--}-toRef :: Reference r => EqRef r a -> r a-toRef (EqRef m) = joinRef $ liftM (\(EqRef_ r k) -> k `lensMap` r) m--instance Reference r => EqReference (EqRef r) where- hasEffect m f = runEqRef m >>= \(EqRef_ r k) -> liftM (\x -> modL k f x /= x) $ readRef r---instance Reference r => Reference (EqRef r) where-- type (RefState (EqRef r)) = RefState r-- readRef = readRef . toRef-- writeRef = writeRef . toRef-- lensMap l (EqRef m) = EqRef $ m >>= \(EqRef_ r k) -> return $ EqRef_ r $ k . l-- joinRef = EqRef . join . liftM runEqRef-- unitRef = eqRef unitRef-
− src/Control/Monad/ExtRef/Pure.hs
@@ -1,127 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE GADTs #-}-{- |-Pure reference implementation for the @ExtRef@ interface.--The implementation uses @unsafeCoerce@ internally, but its effect cannot escape.--}-module Control.Monad.ExtRef.Pure where----import Control.Monad.Base---import Control.Monad.Trans.Control-import Control.Monad.State-import Control.Monad.Reader-import Control.Monad.Identity-import Control.Monad.Operational-import Control.Arrow ((***))-import Data.Sequence hiding (singleton)-import Data.Lens.Common-import Data.Foldable (toList)-import Prelude hiding (splitAt, length)--import Unsafe.Coerce--import Control.Monad.ExtRef------------------- synthetic data types and instances--type SyntRefReader x = Program (RefReaderI x)-data RefReaderI x a where- SyntReadRef :: SyntRef x a -> RefReaderI x a--type SyntRefState x = Program (RefStateI x)-data RefStateI x a where- SyntLiftRefReader :: SyntRefReader x a -> RefStateI x a- SyntWriteRef :: SyntRef x a -> a -> RefStateI x ()--instance MonadRefState (SyntRefState x) where- type RefStateReader (SyntRefState x) = SyntRefReader x- liftRefStateReader = singleton . SyntLiftRefReader--data SyntRef x a where- SyntUnitRef :: SyntRef x ()- SyntLensMap :: Lens' a b -> SyntRef x a -> SyntRef x b- SyntJoinRef :: SyntRefReader x (SyntRef x a) -> SyntRef x a- SyntCreatedRef :: x a -> SyntRef x a--instance Reference (SyntRef x) where- type RefState (SyntRef x) = SyntRefState x- readRef = singleton . SyntReadRef- writeRef r = singleton . SyntWriteRef r- lensMap = SyntLensMap- joinRef = SyntJoinRef- unitRef = SyntUnitRef--type SyntExtRef x = Program (ExtRefI x)-data ExtRefI x a where- SyntLiftRefState :: SyntRefState x a -> ExtRefI x a- SyntExtRef :: SyntRef x b -> Lens' a b -> a -> ExtRefI x (SyntRef x a)--- SyntNewRef :: a -> ExtRefI x (SyntRef x a)--instance ExtRef (SyntExtRef x) where- type Ref (SyntExtRef x) = SyntRef x- liftWriteRef w = singleton $ SyntLiftRefState w- extRef r l = singleton . SyntExtRef r l--- newRef = singleton . SyntNewRef---------------------------newtype Lens_ a b = Lens_ {unLens_ :: Lens' a b}--type LSt = Seq CC--data CC = forall a . CC (LSt -> a -> a) a--initLSt :: LSt-initLSt = empty---runSyntRefReader :: SyntRefReader (Lens_ x) a -> Reader x a-runSyntRefReader = interpretWithMonad eval where- eval (SyntReadRef r) = reader $ getL $ unLens_ $ runSyntRef r--runSyntRefState :: SyntRefState (Lens_ x) a -> State x a-runSyntRefState = interpretWithMonad eval where- eval (SyntLiftRefReader r) = liftRefStateReader $ runSyntRefReader r- eval (SyntWriteRef r a) = modify $ setL (unLens_ $ runSyntRef r) a--runSyntRef :: SyntRef (Lens_ x) a -> Lens_ x a-runSyntRef SyntUnitRef = Lens_ $ lens (const ()) $ const . id-runSyntRef (SyntLensMap l r) = Lens_ $ (unLens_ $ runSyntRef r) . l-runSyntRef (SyntJoinRef m) = (\f -> Lens_ $ \g s -> unLens_ (f s) g s) $ runReader $ liftM runSyntRef $ runSyntRefReader m-runSyntRef (SyntCreatedRef l) = l--runExtRef :: Monad m => SyntExtRef (Lens_ LSt) a -> StateT LSt m a-runExtRef = interpretWithMonad eval where- eval (SyntLiftRefState w) = mapStateT (return . runIdentity) $ runSyntRefState w- eval (SyntExtRef r r2 a0) = state extend- where- r1 = runSyntRef r-- rk = setL (unLens_ r1) . getL r2- kr = setL r2 . getL (unLens_ r1)-- extend x0 = (SyntCreatedRef $ Lens_ $ lens get set, x0 |> CC kr (kr x0 a0))- where- limit = (id *** toList) . splitAt (length x0)-- get = unsafeData . head . snd . limit-- set x a = foldl (\x -> (|>) x . ap_ x) (rk a zs |> CC kr a) ys where- (zs, _ : ys) = limit x-- ap_ :: LSt -> CC -> CC- ap_ x (CC f a) = CC f (f x a)-- unsafeData :: CC -> a- unsafeData (CC _ a) = unsafeCoerce a---- eval (SyntNewRef a) = newRef a-
− src/Control/Monad/ExtRef/Test.hs
@@ -1,289 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}--- | Tests for the @ExtRef@ interface.-module Control.Monad.ExtRef.Test- ( -- * Tests for the interface- mkTests- -- * Tests for implementations- , testExtPure--- , testExtIORef- ) where--import Control.Monad.State-import Control.Monad.Writer-import Control.Category-import Control.Arrow ((***))-import Data.Maybe-import Prelude hiding ((.), id)--import Data.Lens.Common-import Control.Monad.ExtRef-import qualified Control.Monad.ExtRef.Pure as Pure---import qualified Control.Monad.ExtRef.IORef as IORef----------------------------------------------------------------------- | Consistency tests for the pure implementation of @Ext@, should give an empty list of errors.-testExtPure :: [String]-testExtPure = mkTests $ \t -> flip evalState Pure.initLSt $ Pure.runExtRef $ execWriterT t--{---- | Consistency tests for the @IORef@-based implementation of @Ext@, should give an empty list of errors.-testExtIORef :: [String]-testExtIORef = mkTests $ \t -> execWriter $ IORef.runExt t- -- IORef.Ext i (Writer [String])--}---- | Check an equality.-(==?) :: (Eq a, Show a, MonadWriter [String] m) => a -> a -> m ()-rv ==? v = when (rv /= v) $ tell . return $ "runTest failed: " ++ show rv ++ " /= " ++ show v---- | Check the current value of a given reference.-(==>) :: (Eq a, Show a, MonadWriter [String] m, ExtRef m) => Ref m a -> a -> m ()-r ==> v = readRef' r >>= (==? v)--infix 0 ==>, ==?--{- | -@mkTests@ generates a list of error messages which should be emtpy.--Look inside the sources for the tests.--}-mkTests :: ((forall m . (MonadWriter [String] m, ExtRef m) => m ()) -> [String]) -> [String]-mkTests runTest- = newRefTest- ++ writeRefTest- ++ writeRefsTest- ++ extRefTest- ++ joinTest- ++ joinTest2- ++ chainTest0- ++ forkTest- ++ forkTest2- ++ chainTest- ++ undoTest- ++ undoTest2- ++ undoTest3- where-- newRefTest = runTest $ do- r <- newRef 3- r ==> 3-- writeRefTest = runTest $ do- r <- newRef 3- r ==> 3- writeRef' r 4- r ==> 4-- writeRefsTest = runTest $ do- r1 <- newRef 3- r2 <- newRef 13- r1 ==> 3- r2 ==> 13- writeRef' r1 4- r1 ==> 4- r2 ==> 13- writeRef' r2 0- r1 ==> 4- r2 ==> 0-- extRefTest = runTest $ do- r <- newRef $ Just 3- q <- extRef r maybeLens (False, 0)- let q1 = fstLens `lensMap` q- q2 = sndLens `lensMap` q- r ==> Just 3- q ==> (True, 3)- writeRef' r Nothing- r ==> Nothing- q ==> (False, 3)- q1 ==> False- writeRef' q1 True- r ==> Just 3- writeRef' q2 1- r ==> Just 1-- joinTest = runTest $ do- r2 <- newRef 5- r1 <- newRef 3- rr <- newRef r1- r1 ==> 3- let r = joinRef' rr- r ==> 3- writeRef' r1 4- r ==> 4- writeRef' rr r2- r ==> 5- writeRef' r1 4- r ==> 5- writeRef' r2 14- r ==> 14-- joinTest2 = runTest $ do- r1 <- newRef 3- rr <- newRef r1- r2 <- newRef 5- writeRef' rr r2- joinRef' rr ==> 5-- chainTest0 = runTest $ do- r <- newRef 1- q <- extRef r id 0- s <- extRef q id 0- r ==> 1- q ==> 1- s ==> 1- writeRef' r 2- r ==> 2- q ==> 2- s ==> 2- writeRef' q 3- r ==> 3- q ==> 3- s ==> 3- writeRef' s 4- r ==> 4- q ==> 4- s ==> 4-- forkTest = runTest $ do- r <- newRef 1- q <- extRef r id 0- s <- extRef r id 0- r ==> 1- q ==> 1- s ==> 1- writeRef' r 2- r ==> 2- q ==> 2- s ==> 2- writeRef' q 3- r ==> 3- q ==> 3- s ==> 3- writeRef' s 4- r ==> 4- q ==> 4- s ==> 4-- forkTest2 = runTest $ do- r <- newRef $ Just 1- q <- extRef r maybeLens (False, 0)- s <- extRef r maybeLens (False, 0)- r ==> Just 1- q ==> (True, 1)- s ==> (True, 1)- writeRef' r $ Just 2- r ==> Just 2- q ==> (True, 2)- s ==> (True, 2)- writeRef' r Nothing- r ==> Nothing- q ==> (False, 2)- s ==> (False, 2)- writeRef' (fstLens `lensMap` q) True- r ==> Just 2- q ==> (True, 2)- s ==> (True, 2)- writeRef' (sndLens `lensMap` q) 3- r ==> Just 3- q ==> (True, 3)- s ==> (True, 3)- writeRef' (fstLens `lensMap` q) False- r ==> Nothing- q ==> (False, 3)- s ==> (False, 3)- writeRef' (sndLens `lensMap` q) 4- r ==> Nothing- q ==> (False, 4)- s ==> (False, 3)- writeRef' (fstLens `lensMap` q) True- r ==> Just 4- q ==> (True, 4)- s ==> (True, 4)- writeRef' q (False, 5)- r ==> Nothing- q ==> (False, 5)- s ==> (False, 4)- writeRef' (fstLens `lensMap` s) True- r ==> Just 4- q ==> (True, 4)- s ==> (True, 4)-- chainTest = runTest $ do- r <- newRef $ Just $ Just 3- q <- extRef r maybeLens (False, Nothing)- s <- extRef (sndLens `lensMap` q) maybeLens (False, 0)- r ==> Just (Just 3)- q ==> (True, Just 3)- s ==> (True, 3)- writeRef' (fstLens `lensMap` s) False- r ==> Just Nothing- q ==> (True, Nothing)- s ==> (False, 3)- writeRef' (fstLens `lensMap` q) False- r ==> Nothing- q ==> (False, Nothing)- s ==> (False, 3)- writeRef' (fstLens `lensMap` s) True- r ==> Nothing- q ==> (False, Just 3)- s ==> (True, 3)- writeRef' (fstLens `lensMap` q) True- r ==> Just (Just 3)- q ==> (True, Just 3)- s ==> (True, 3)-- undoTest = runTest $ do- r <- newRef 3- q <- extRef r (lens head $ flip (:)) []- writeRef' r 4- q ==> [4, 3]-- undoTest2 = runTest $ do- r <- newRef 3- q <- extRef r (lens head $ flip (:)) []- q ==> [3]-- undoTest3 = runTest $ do- r <- newRef 3- (undo, redo) <- liftM (liftRefStateReader *** liftRefStateReader) $ undoTr (==) r- r ==> 3- redo === False- undo === False- writeRef' r 4- r ==> 4- redo === False- undo === True- writeRef' r 5- r ==> 5- redo === False- undo === True- push undo- r ==> 4- redo === True- undo === True- push undo- r ==> 3- redo === True- undo === False- push redo- r ==> 4- redo === True- undo === True- writeRef' r 6- r ==> 6- redo === False- undo === True- where- push m = liftWriteRef m >>= \x -> maybe (return ()) liftWriteRef x- m === t = liftWriteRef m >>= \x -> isJust x ==? t-- joinRef' r = joinRef $ readRef r-- writeRef' r a = liftWriteRef $ writeRef r a-
− src/Control/Monad/Restricted.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module Control.Monad.Restricted where--import Data.Monoid-import Control.Concurrent-import Control.Monad.State-import qualified System.Environment as Env-import System.IO.Error (catchIOError, isDoesNotExistError)--{- |-Monad morphism. Think as @m@ is a submonad of @n@.--}-type Morph m n = forall a . m a -> n a--{- |-The @MorphD@ type is needed only to avoid impredicative types.-We use @MorphD@ instead of @Morph@ when the morphism is stored inside a data structure.--}-newtype MorphD m n = MorphD { runMorphD :: Morph m n }-----------------------class (Monad m) => NewRef m where- newRef' :: a -> m (MorphD (StateT a m) m)--instance NewRef IO where- newRef' x = do- vx <- liftIO $ newMVar x- return $ MorphD $ \m -> modifyMVar vx $ liftM swap . runStateT m- where- swap (a, b) = (b, a)------------------------- | Type class for effectless, synchronous @IO@ actions.-class Monad m => SafeIO m where-- -- | The program's command line arguments (not including the program name). - getArgs :: m [String]-- -- | The name of the program as it was invoked.- getProgName :: m String-- -- | @(lookupEnv var)@ returns the value of the environment variable @var@.- lookupEnv :: String -> m (Maybe String)---- | This instance is used in the implementation, the end users do not need it.-instance SafeIO IO where-- getArgs = Env.getArgs- getProgName = Env.getProgName--- lookupEnv = Env.lookupEnv -- does not work with Haskell Platform 2013.2.0.0- lookupEnv v = catchIOError (liftM Just $ Env.getEnv v) $ \e ->- if isDoesNotExistError e then return Nothing else ioError e-----------------------newtype MonadMonoid a = MonadMonoid { runMonadMonoid :: a () }--instance Monad m => Monoid (MonadMonoid m) where- mempty = MonadMonoid $ return ()- MonadMonoid a `mappend` MonadMonoid b = MonadMonoid $ a >> b--
− src/Data/Lens/Common.hs
@@ -1,67 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-module Data.Lens.Common- ( Lens- , Lens'- -- * Lens construction- , lens -- build a lens from a getter and setter- -- * Functional API- , getL -- (^.)- , setL -- set- , modL -- over- -- * Stock lenses- , fstLens- , sndLens- , showLens- , listLens- , maybeLens- ) where--import Data.Maybe-import Control.Applicative-import Control.Monad.Identity----------- re-define to avoid dependency on lens-type Lens s t a b = Functor f => (a -> f b) -> s -> f t-type Lens' s a = Lens s s a a--lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b-lens sa sbt afb s = sbt s <$> afb (sa s)---- | build a lens out of an isomorphism-iso :: (s -> a) -> (b -> t) -> Lens s t a b-iso f g = lens f $ flip $ const . g---- | Gets the getter function from a lens.-getL :: Lens' a b -> a -> b-getL l = getConst . l Const---- | Gets the setter function from a lens.-setL :: Lens s t a b -> b -> s -> t-setL l s = runIdentity . l (const $ Identity s)---- | Gets the modifier function from a lens.-modL :: Lens s t a b -> (a -> b) -> s -> t-modL l f = runIdentity . l (Identity . f)---- * Stock lenses-fstLens :: Lens (x,b) (y,b) x y-fstLens = lens fst $ \(a,b) x -> (x,b)--sndLens :: Lens (a,x) (a,y) x y-sndLens = lens snd $ \(a,b) x -> (a,x)--showLens :: (Show a, Read a) => Lens' a String-showLens = lens show $ \def s -> maybe def fst $ listToMaybe $ reads s--listLens :: Lens' (Bool, (a, [a])) [a]-listLens = lens get set where- get (False, _) = []- get (True, (l, r)) = l: r- set (_, x) [] = (False, x)- set _ (l: r) = (True, (l, r))--maybeLens :: Lens' (Bool, a) (Maybe a)-maybeLens = lens (\(b,a) -> if b then Just a else Nothing)- (\(_,a) x -> maybe (False, a) (\a' -> (True, a')) x)-
− src/GUI/Gtk/Structures.hs
@@ -1,60 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RankNTypes #-}--- | Lens-based Gtk interface-module GUI.Gtk.Structures- ( module GUI.Gtk.Structures- , module Graphics.UI.Gtk- , Color (..)- ) where--import Graphics.UI.Gtk.Gdk.GC (Color (Color))-import Diagrams.Prelude (QDiagram, R2, Monoid)-import Diagrams.Backend.Cairo (Cairo)-import Graphics.UI.Gtk (ScrollDirection (..), KeyVal, Modifier, keyName, keyToChar)--import Control.Monad.EffRef (Command (..))--type Dia a = QDiagram Cairo R2 a--type Send n m a = (a -> n ()) -> m ()-type Receive n m k a = (Command -> n ()) -> m (a -> k ())-type SendReceive n m k a = (Send n m a, Receive n m k a)--type Widget n m k = m (WidgetCore n m k)---- | Widget descriptions-data WidgetCore n m k- = Label (Send n m String) -- ^ label- | Button { label_ :: Send n m String- , sensitive_ :: Send n m Bool- , color_ :: Send n m Color- , action_ :: Receive n m k ()- } -- ^ button- | Checkbox (SendReceive n m k Bool) -- ^ checkbox- | Combobox [String] (SendReceive n m k Int) -- ^ combo box- | Entry (SendReceive n m k String) -- ^ entry field- | List ListLayout [Widget n m k] -- ^ group interfaces into row or column- | Notebook' (Receive n m k Int) [(String, Widget n m k)] -- ^ actual tab index, tabs- | forall b . Eq b => Cell ((b -> m (m ())) -> m ()) (forall a . (Widget n m k -> m a) -> b -> m (m a))- | forall a b . (Eq b, Eq a, Monoid a) => Canvas Int Int Double (Receive n m k (MouseEvent a)) (Send n m b) (b -> Dia a)- | Scale Double Double Double (SendReceive n m k Double)--data ListLayout- = Horizontal- | Vertical- deriving (Eq)--data MouseEvent a- = MoveTo (MousePos a)- | MouseEnter (MousePos a)- | MouseLeave (MousePos a)- | Click (MousePos a)- | DragTo (MousePos a)- | Release (MousePos a)- | ScrollTo ScrollDirection (MousePos a)- | KeyPress [Modifier] KeyVal- deriving (Eq)--data MousePos a- = MousePos (Double, Double) a- deriving (Eq)
− src/GUI/Gtk/Structures/IO.hs
@@ -1,302 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RecursiveDo #-}-module GUI.Gtk.Structures.IO- ( runWidget- ) where--import Control.Category-import Control.Monad-import Control.Monad.State-import Control.Monad.Writer-import Control.Concurrent-import Data.Maybe-import Data.List hiding (union)-import Prelude hiding ((.), id)--import Graphics.UI.Gtk hiding (Widget, Release)-import qualified Graphics.UI.Gtk as Gtk---import Graphics.UI.Gtk.Gdk.Events (eventKeyChar)--import Control.Monad.Restricted-import Control.Monad.ExtRef-import Control.Monad.ExtRef.Pure-import Control.Monad.EffRef-import GUI.Gtk.Structures--import Diagrams.Prelude-import Diagrams.Backend.Cairo-import Diagrams.Backend.Cairo.Internal-----------------------------{- |-Run a Gtk widget description.--The widget is shown in a window and the thread enters into the Gtk event cycle.-It leaves the event cycle when the window is closed.--}-runWidget :: (forall m . EffIORef m => Widget (EffectM m) m (CallbackM m)) -> IO ()-runWidget desc = gtkContext $ \postGUISync -> mdo- postActionsRef <- newRef' $ return ()- let addPostAction = runMorphD postActionsRef . modify . flip (>>)- runPostActions = join $ runMorphD postActionsRef $ state $ \m -> (m, return ())- actionChannel <- newChan- ((widget, (act, _)), s) <- flip runStateT initLSt $ runWriterT $ evalRegister' (writeChan actionChannel) $- runWidget_ id addPostAction postGUISync id id liftIO__ liftIO desc- runPostActions- _ <- forkIO $ void $ flip execStateT s $ forever $ do- join $ lift $ readChan actionChannel- runMonadMonoid act- lift $ runPostActions- return widget---gtkContext :: (Morph IO IO -> IO SWidget) -> IO ()-gtkContext m = do- _ <- unsafeInitGUIForThreadedRTS- tid <- myThreadId- let post :: Morph IO IO- post e = do- tid' <- myThreadId- if tid' == tid then e else postGUISync e- c <- m post- window <- windowNew- set window [ containerBorderWidth := 10, containerChild := snd c ]- _ <- window `on` deleteEvent $ liftIO mainQuit >> return False- widgetShowAll window- mainGUI--type SWidget = (IO (), Gtk.Widget)---- | Run an @IO@ parametrized interface description with Gtk backend-runWidget_- :: forall n m k o . (Monad m, Monad o)- => (k () -> IO ())- -> (IO () -> IO ())- -> Morph IO IO- -> Morph m o- -> Morph o m- -> Morph IO o- -> (IO () -> n ())- -> Widget n m k- -> o SWidget-runWidget_ nio post' post liftO liftOBack liftIO_ liftION = toWidget- where- liftIO' :: IO a -> o a- liftIO' = liftIO_ . post-- -- type Receive n m k a = (Command -> n ()) -> m (a -> k ())- reg :: Receive n m k a -> ((a -> IO ()) -> IO (Command -> IO ())) -> o (Command -> IO ())- reg s f = do- rer <- liftIO_ newEmptyMVar- u <- liftIO_ $ f $ \x -> do- re <- readMVar rer- nio $ re x- re <- liftO $ s $ liftION . post . u- liftIO_ $ putMVar rer re- return u-- ger :: (Command -> IO ()) -> Send n m a -> Send IO o a- ger hd s f = liftO $ s $ \a -> liftION $ post $ do- hd Block- f a- hd Unblock-- nhd :: Command -> IO ()- nhd = const $ return ()-- toWidget :: Widget n m k -> o SWidget- toWidget m = liftO m >>= \i -> case i of---- Action m -> liftO m >>= toWidget- Label s -> do- w <- liftIO' $ labelNew Nothing- ger nhd s $ labelSetLabel w- return' w-- Canvas w h sc_ me r diaFun -> do-- cur <- liftIO_ $ newMVar Nothing- cur' <- liftIO_ $ newMVar Nothing- v <- liftIO_ newEmptyMVar-- (canvasDraw, canvas, af, dims) <- liftIO' $ do- canvas <- drawingAreaNew- widgetAddEvents canvas [PointerMotionMask]- af <- aspectFrameNew 0.5 0.5 (Just $ fromIntegral w / fromIntegral h)- _ <- canvas `onSizeRequest` return (Requisition w h)- _ <- containerAdd af canvas- let- dims = do- win <- widgetGetDrawWindow canvas- (w, h) <- drawableGetSize win- let (w', h') = (fromIntegral w, fromIntegral h)- let sc = w' / sc_- return (sc, w', h', w, h)-- tr sc w h dia = translate (r2 (w/2, h/2)) $ dia # scaleY (-1) # scale sc `atop` rect w h # fc white # lw 0-- draw dia_ = do- _ <- swapMVar cur $ Just dia_- let dia = freeze $ clearValue dia_- (sc, w, h, wi, he) <- dims- win <- widgetGetDrawWindow canvas- drawWindowBeginPaintRect win $ Rectangle 0 0 wi he- renderWithDrawable win $ snd $ renderDia Cairo (CairoOptions "" (Width w) RenderOnly True) $ tr sc w h dia- drawWindowEndPaint win-- return (draw, canvas, af, dims)-- let -- compCoords :: (Double, Double) -> IO (MousePos a)- compCoords (x,y) = do- (sc, w, h, _, _) <- dims- d <- readMVar cur- let p = ((x - w / 2) / sc, (h / 2 - y) / sc)- return $ MousePos p $ maybe mempty (`sample` p2 p) d-- _ <- reg me $ \re -> do- _ <- on' canvas buttonPressEvent $ tryEvent $ do--- click <- eventClick- p <- eventCoordinates >>= liftIO . compCoords- liftIO $ re $ Click p- _ <- on' canvas buttonReleaseEvent $ tryEvent $ do--- click <- eventClick- p <- eventCoordinates >>= liftIO . compCoords- liftIO $ re $ Release p- _ <- on' canvas enterNotifyEvent $ tryEvent $ do- p <- eventCoordinates >>= liftIO . compCoords- liftIO $ re $ MouseEnter p- _ <- on' canvas leaveNotifyEvent $ tryEvent $ do- p <- eventCoordinates >>= liftIO . compCoords- liftIO $ re $ MouseLeave p- _ <- on' canvas motionNotifyEvent $ tryEvent $ do- p <- eventCoordinates >>= liftIO . compCoords- liftIO $ re $ MoveTo p- _ <- on' canvas scrollEvent $ tryEvent $ do- p <- eventCoordinates >>= liftIO . compCoords- dir <- eventScrollDirection- liftIO $ re $ ScrollTo dir p- on' canvas keyPressEvent $ tryEvent $ do--- p <- eventCoordinates >>= liftIO . compCoords- m <- eventModifier- c <- eventKeyVal- liftIO $ re $ KeyPress m c- _ <- liftIO_ $ on canvas exposeEvent $ tryEvent $ liftIO $ do- d <- readMVar cur'- case d of- Just x -> putMVar v x- _ -> return ()-- canvasDraw' <- liftIO_ $ do- v2 <- newMVar False- _ <- forkIO $ do- threadDelay 200000- forever $ do- threadDelay 10000- dia <- takeMVar v- _ <- swapMVar cur' $ Just dia- _ <- swapMVar v2 True- let d = diaFun dia- post $ canvasDraw d- _ <- swapMVar v2 False- return ()- return $ \dia -> do- b <- readMVar v2- unless b $ do- _ <- tryTakeMVar v- putMVar v dia-- ger nhd r canvasDraw'- return' af-- Button s sens col m -> do- w <- liftIO' buttonNew- hd <- reg m $ \re -> on' w buttonActivated $ re ()- ger hd s $ buttonSetLabel w- ger hd sens $ widgetSetSensitive w- ger hd col $ \c -> do- widgetModifyBg w StateNormal c- widgetModifyBg w StatePrelight c- return' w- Entry (r, s) -> do- w <- liftIO' entryNew- hd <- reg s $ \re -> on' w entryActivate $ entryGetText w >>= re- hd' <- reg s $ \re -> on' w focusOutEvent $ lift $ entryGetText w >>= re >> return False- ger (\x -> hd x >> hd' x) r $ entrySetText w- return' w- Checkbox (r, s) -> do- w <- liftIO' checkButtonNew- hd <- reg s $ \re -> on' w toggled $ toggleButtonGetActive w >>= re- ger hd r $ toggleButtonSetActive w- return' w- Scale a b c (r, s) -> do- w <- liftIO' $ hScaleNewWithRange a b c- _ <- liftIO' $ w `onSizeRequest` return (Requisition 200 40)- hd <- reg s $ \re -> on' w valueChanged $ rangeGetValue w >>= re- ger hd r $ rangeSetValue w- return' w- Combobox ss (r, s) -> do- w <- liftIO' comboBoxNewText- _ <- liftIO' $ w `onSizeRequest` return (Requisition 50 30)- liftIO' $ flip mapM_ ss $ comboBoxAppendText w- hd <- reg s $ \re -> on' w changed $ fmap (max 0) (comboBoxGetActive w) >>= re- ger hd r $ comboBoxSetActive w- return' w- List o xs -> do- ws <- mapM toWidget xs- w <- liftIO' $ case o of- Vertical -> fmap castToBox $ vBoxNew False 1- Horizontal -> fmap castToBox $ hBoxNew False 1- shs <- forM ws $ liftIO' . containerAdd'' w . snd- liftM (mapFst (sequence_ shs >>)) $ return'' ws w- Notebook' s xs -> do- ws <- mapM (toWidget . snd) xs- w <- liftIO' notebookNew- forM_ (zip ws xs) $ \(ww, (s, _)) -> do- liftIO' . flip (notebookAppendPage w) s $ snd $ ww- _ <- reg s $ \re -> on' w switchPage $ re- return'' ws w- Cell onCh f -> do- let b = False- w <- liftIO' $ case b of- True -> fmap castToContainer $ hBoxNew False 1- False -> fmap castToContainer $ alignmentNew 0 0 1 1- sh <- liftIO_ $ newMVar $ return ()- liftO $ onCh $ \bv -> do- mx <- f (liftOBack . toWidget) bv- return $ mx >>= \(x, y) -> liftOBack $ liftIO' $ do - _ <- swapMVar sh x- containerForeach w $ if b then widgetHideAll else containerRemove w - post' $ post $ do- ch <- containerGetChildren w- when (y `notElem` ch) $ containerAdd w y- x- liftM (mapFst (join (readMVar sh) >>)) $ return'' [] w--on' :: GObjectClass x => x -> Signal x c -> c -> IO (Command -> IO ())-on' o s c = liftM (flip f) $ on o s c where- f Kill = signalDisconnect- f Block = signalBlock- f Unblock = signalUnblock--return' :: Monad m => WidgetClass x => x -> m SWidget-return' w = return (widgetShowAll w, castToWidget w)--return'' :: Monad m => WidgetClass x => [SWidget] -> x -> m SWidget-return'' ws w = return (mapM_ fst ws >> widgetShow w, castToWidget w)--mapFst f (a, b) = (f a, b)--containerAdd'' w x = do- a <- alignmentNew 0 0 0 0- containerAdd a x- containerAdd w a- set w [ boxChildPacking a := PackNatural ]- return $ widgetShow a--
src/LGtk.hs view
@@ -1,50 +1,57 @@+{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-} -- | Main LGtk interface. module LGtk ( -- * References+ module Data.LensRef - -- ** Reference modifying monad- MonadRefState (..)+ -- * GUI - -- ** Reference operations- , Reference- , RefState- , RefReader- , readRef- , writeRef- , lensMap- , joinRef- , unitRef+ -- ** Running a widget+ , Widget+ , runWidget - -- ** Reference creation- , ExtRef- , Ref- , extRef- , newRef- , ReadRef- , WriteRef- , liftReadRef+ -- ** GUI elements+ , empty+ , vcat+ , hcat+ , label+ , button+ , smartButton+ , checkbox+ , combobox+ , entry+ , entryShow+ , hscale+ , cell+ , cellNoMemo+ , notebook - -- ** Derived constructs- , modRef- , readRef'- , memoRead- , undoTr+ -- ** Other elements+ , button_+ , button__+ , cell_ - , EqReference (..)- , EqRef- , eqRef- , newEqRef- , toRef+ -- ** Diagrams canvas+ , canvas+ , inCanvas - -- * Dynamic networks- , EffRef- , onChange+ -- * Aux types+ , Dia+ , MouseEvent (..)+ , MousePos (..)+ , Colour+ , sRGB+ , module LGtk.Key -- * I/O- , SafeIO , getArgs , getProgName , lookupEnv@@ -54,66 +61,35 @@ , putStr_ , getLine_ , fileRef-- -- ** Derived constructs , putStrLn_ - -- * GUI-- -- ** Running- , Widget- , runWidget--- , runWidget'-- -- ** GUI descriptions- , label- , checkbox- , combobox- , entry- , vcat- , hcat- , button_- , Color (..)- , notebook- , cell_- , action- , canvas- , Dia- , MouseEvent (..)- , MousePos (..)- , Modifier- , KeyVal- , keyName- , keyToChar- , ScrollDirection (..)- , hscale-- -- ** Derived constructs- , empty- , entryShow- , button- , smartButton- , cell- , cellNoMemo-- -- ** Experimental- , button__+ -- * Utils+ , undoTr+ , showLens+ , listLens ) where +--import Data.String import Data.Maybe import Data.Monoid+import Data.Semigroup import Control.Monad-import Data.Lens.Common+import Control.Lens -import Control.Monad.ExtRef-import Control.Monad.EffRef-import GUI.Gtk.Structures hiding (Send, Receive, SendReceive, Widget)-import qualified GUI.Gtk.Structures as Gtk-import qualified GUI.Gtk.Structures.IO as Gtk-import Control.Monad.Restricted+import Data.LensRef+import LGtk.Effects+import LGtk.Widgets+import LGtk.Render+import LGtk.Key +#ifdef __GTK__+import LGtk.Backend.Gtk+#else+import LGtk.Backend.GLFW+#endif + {- | Gtk widget descriptions. Construction of a @(w :: forall m . EffIORef m => Widget m)@ value is side-effect free,@@ -122,9 +98,7 @@ @Widget@ should be abstract data type, but it is also safe to keep it as a type synonym because the operations of the revealed implementation are hidden. -}-type Widget m = Gtk.Widget (EffectM m) m (CallbackM m)----type SyntWidget = Widget (SyntEffIORef X)+--runWidgetGLFW = GLFW.runWidget {- | Run a Gtk widget description.@@ -132,8 +106,12 @@ The widget is shown in a window and the thread enters into the Gtk event cycle. It leaves the event cycle when the window is closed. -}-runWidget :: (forall m . EffIORef m => Widget m) -> IO ()-runWidget = Gtk.runWidget+--runWidget :: (forall m . EffIORef m => Widget m) -> IO ()+--runWidget = Gtk.runWidget+{-+instance MonadRefState m => IsString (RefStateReader m String) where+ fromString = return+-} -- | Vertical composition of widgets. vcat :: Monad m => [Widget m] -> Widget m@@ -148,103 +126,157 @@ empty = hcat [] -- | Dynamic label.-label :: EffRef m => ReadRef m String -> Widget m-label = return . Label . rEffect True+label :: MonadRegister m => RefReader m String -> Widget m+label = return . Label -- | Low-level button with changeable background color. button__- :: EffRef m- => ReadRef m String -- ^ dynamic label of the button- -> ReadRef m Bool -- ^ the button is active when this returns @True@- -> ReadRef m Color -- ^ dynamic background color- -> WriteRef m () -- ^ the action to do when the button is pressed+ :: MonadRegister m+ => RefReader m String -- ^ dynamic label of the button+ -> RefReader m Bool -- ^ the button is active when this returns @True@+ -> RefReader m (Colour Double) -- ^ dynamic background color+ -> Modifier m () -- ^ the action to do when the button is pressed -> Widget m-button__ r x c y = return $ Button (rEffect True r) (rEffect True x) (rEffect True c) (toReceive $ \() -> y)+button__ r x c y = return $ Button (r) (x) (Just c) (\() -> y) -- | Low-level button. button_- :: EffRef m- => ReadRef m String -- ^ dynamic label of the button- -> ReadRef m Bool -- ^ the button is active when this returns @True@- -> WriteRef m () -- ^ the action to do when the button is pressed+ :: MonadRegister m+ => RefReader m String -- ^ dynamic label of the button+ -> RefReader m Bool -- ^ the button is active when this returns @True@+ -> Modifier m () -- ^ the action to do when the button is pressed -> Widget m-button_ r x y = return $ Button (rEffect True r) (rEffect True x) (const $ return ()) (toReceive $ \() -> y)+button_ r x y = return $ Button (r) (x) Nothing (\() -> y) +-- | Button button- :: EffRef m- => ReadRef m String -- ^ dynamic label of the button- -> ReadRef m (Maybe (WriteRef m ())) -- ^ when the @Maybe@ value is @Nothing@, the button is inactive+ :: MonadRegister m+ => RefReader m String -- ^ dynamic label of the button+ -> RefReader m (Maybe (Modifier m ())) -- ^ when the @Maybe@ value is @Nothing@, the button is inactive -> Widget m-button r fm = button_ r (liftM isJust fm) (liftRefStateReader fm >>= maybe (return ()) id)--+button r fm = button_ r (liftM isJust fm) (liftRefReader fm >>= maybe (return ()) id) +-- | Button which inactivates itself automatically. smartButton- :: (EffRef m, EqReference r, RefState r ~ RefState (Ref m)) - => ReadRef m String -- ^ dynamic label of the button- -> r a -- ^ underlying reference+ :: (MonadRegister m, EqRefClass r, RefReaderSimple r ~ RefReader m) + => RefReader m String -- ^ dynamic label of the button+ -> RefSimple r a -- ^ underlying reference -> (a -> a) -- ^ The button is active when this function is not identity on value of the reference. When the button is pressed, the value of the reference is modified with this function. -> Widget m smartButton s r f = button_ s (hasEffect r f) (modRef r f) -- | Checkbox.-checkbox :: EffRef m => Ref m Bool -> Widget m-checkbox r = return $ Checkbox (rEffect True (readRef r), toReceive $ writeRef r)+checkbox :: MonadRegister m => Ref m Bool -> Widget m+checkbox r = return $ Checkbox ((readRef r), writeRef r) --- | Simple combo box.-combobox :: EffRef m => [String] -> Ref m Int -> Widget m-combobox ss r = return $ Combobox ss (rEffect True (readRef r), toReceive $ writeRef r)+-- | Combo box.+combobox :: MonadRegister m => [String] -> Ref m Int -> Widget m+combobox ss r = return $ Combobox ss ((readRef r), writeRef r) -- | Text entry.-entry :: (EffRef m, Reference r, RefState r ~ RefState (Ref m)) => r String -> Widget m-entry r = return $ Entry (rEffect True (readRef r), toReceive $ writeRef r)+entry :: (MonadRegister m, RefClass r, RefReaderSimple r ~ RefReader m) => RefSimple r String -> Widget m+entry r = return $ Entry (const True) ((readRef r), writeRef r) --- | Text entry.-entryShow :: (EffRef m, Show a, Read a, Reference r, RefState r ~ RefState (Ref m)) => r a -> Widget m-entryShow r = entry $ showLens `lensMap` r+-- | Text entry with automatic show-read conversion.+entryShow :: forall m a r . (MonadRegister m, Show a, Read a, RefClass r, RefReaderSimple r ~ RefReader m) => RefSimple r a -> Widget m+entryShow r_ = return $ Entry isOk ((readRef r), writeRef r)+ where+ r = showLens `lensMap` r_+ isOk s = case (reads s :: [(a, String)]) of+ ((_,""):_) -> True+ _ -> False +showLens :: (Show a, Read a) => Lens' a String+showLens = lens show $ \def s -> maybe def fst $ listToMaybe $ reads s++ {- | Notebook (tabs). The tabs are created lazily. -}-notebook :: EffRef m => [(String, Widget m)] -> Widget m+notebook :: MonadRegister m => [(String, Widget m)] -> Widget m notebook xs = do currentPage <- newRef 0 let f index (title, w) = (,) title $ cell (liftM (== index) $ readRef currentPage) $ \b -> case b of False -> hcat [] True -> w- return $ Notebook' (toReceive $ writeRef currentPage) $ zipWith f [0..] xs+ return $ Notebook' (writeRef currentPage) $ zipWith f [0..] xs {- | Dynamic cell. The monadic action for inner widget creation is memoised in the first monad layer. -}-cell_ :: (EffRef m, Eq a) => ReadRef m a -> (forall x . (Widget m -> m x) -> a -> m (m x)) -> Widget m-cell_ r = return . Cell (onChange True r)+cell_ :: (MonadRegister m, Eq a) => RefReader m a -> (forall x . (Widget m -> m x) -> a -> m (m x)) -> Widget m+cell_ r f = return $ Cell r f {- | Dynamic cell. The inner widgets are memoised. -}-cell :: (EffRef m, Eq a) => ReadRef m a -> (a -> Widget m) -> Widget m+cell :: (MonadRegister m, Eq a) => RefReader m a -> (a -> Widget m) -> Widget m cell r m = cell_ r $ \mk -> liftM return . mk . m {- | Dynamic cell. The inner widgets are not memoised. -}-cellNoMemo :: (EffRef m, Eq a) => ReadRef m a -> (a -> Widget m) -> Widget m+cellNoMemo :: (MonadRegister m, Eq a) => RefReader m a -> (a -> Widget m) -> Widget m cellNoMemo r m = cell_ r $ \mk -> return . mk . m --- | @action@ makes possible to do any 'EffRef' action while creating the widget.-action :: EffRef m => m (Widget m) -> Widget m-action = join+-- | Diagrams canvas.+canvas+ :: (MonadRegister m, Eq b, Monoid a, Semigroup a)+ => Int -- ^ width+ -> Int -- ^ height+ -> Double -- ^ scale+ -> ((MouseEvent a, Dia a) -> Modifier m ()) -- ^ mouse event handler+ -> KeyboardHandler (Modifier m) -- ^ keyboard event handler+ -> RefReader m b -- ^ state references+ -> (b -> Dia a) -- ^ diagrams renderer+ -> Widget m+canvas w h sc me kh r f = return $ Canvas w h sc me kh r f -canvas :: (EffRef m, Eq b, Eq a, Monoid a) => Int -> Int -> Double -> (MouseEvent a -> WriteRef m ()) -> ReadRef m b -> (b -> Dia a) -> Widget m-canvas w h sc me r f = return $ Canvas w h sc (toReceive me) (rEffect True r) f- -- = cellNoMemo r $ Canvas_ w h sc . f -- Canvas f $ rEffect True r+hscale+ :: (MonadRegister m)+ => Double -- ^ min+ -> Double -- ^ max+ -> Double -- ^ step+ -> Ref m Double+ -> Widget m+hscale a b c r = return $ Scale a b c (readRef r, writeRef r) -hscale :: (EffRef m) => Double -> Double -> Double -> Ref m Double -> Widget m-hscale a b c r = return $ Scale a b c (rEffect True $ readRef r, toReceive $ writeRef r)+listLens :: Lens' (Bool, (a, [a])) [a]+listLens = lens get set where+ get (False, _) = []+ get (True, (l, r)) = l: r+ set (_, x) [] = (False, x)+ set _ (l: r) = (True, (l, r))+++-- | Undo-redo state transformation.+undoTr+ :: MonadRegister m =>+ (a -> a -> Bool) -- ^ equality on state+ -> Ref m a -- ^ reference of state+ -> m ( RefReader m (Maybe (Modifier m ()))+ , RefReader m (Maybe (Modifier m ()))+ ) -- ^ undo and redo actions+undoTr eq r = do+ ku <- extRef r (undoLens eq) ([], [])+ let try f = liftM (liftM (writeRef ku) . f) $ readRef ku+ return (try undo, try redo)+ where+ undo (x: xs@(_:_), ys) = Just (xs, x: ys)+ undo _ = Nothing++ redo (xs, y: ys) = Just (y: xs, ys)+ redo _ = Nothing++undoLens :: (a -> a -> Bool) -> Lens' ([a],[a]) a+undoLens eq = lens get set where+ get = head . fst+ set (x' : xs, ys) x | eq x x' = (x: xs, ys)+ set (xs, _) x = (x : xs, [])+
− src/LGtk/ADTEditor.hs
@@ -1,100 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE RankNTypes #-}--- | A generic ADT editor defined on top of the main LGtk interface, "LGtk".-module LGtk.ADTEditor- ( Lens_ (..), List (..), Elems(..), ADTLens(..)- , adtEditor- ) where--import Control.Monad-import Data.Lens.Common-import LGtk--newtype Lens_ a b = Lens_ {unLens_ :: Lens' a b}---- | Type-level lists-data List a = Nil | Cons a (List a)---- | Heterogeneous lists-data Elems (xs :: List *) where- ElemsNil :: Elems Nil- ElemsCons :: ADTLens a => a -> Elems as -> Elems (Cons a as)--{- | Lens for editable ADTs with support of shared record fields between constructors.--Suppose we have the data type--@-data X- = X1 { a :: Int, b :: Bool }- | X2 { a :: Int, c :: Char }-@--We can build an editor which can switch between two editor for the constructors.-If the field @a@ is edited in one editor, it will be updated in the other.--}-class ADTLens a where-- {- | @ADTEls a@ is the list of types of the parts of the ADT.-- For example,-- @ADTEls X = Cons Int (Cons Bool (Cons Char Nil))@- -}- type ADTEls a :: List *-- {- | The lens which defines an abstract editor.-- The first parameter defines the displayed constructor name and the parts of the constructor for each constructor.- @Int@ is an index in the @ADTEls@ list.-- For example, in case of @X@,-- @fst3 adtLens = [(\"X1\", [0, 1]), (\"X2\", [0, 2])]@-- The second parameter is the list of default values for each part.-- The third parameter is a lens from the selected constructor index plus- the values of the ADT parts to the ADT values.- -}- adtLens :: ([(String, [Int])], Elems (ADTEls a), Lens_ (Int, Elems (ADTEls a)) a)---- | A generic ADT editor-adtEditor :: (EffRef m, ADTLens a) => Ref m a -> m (Widget m)-adtEditor = liftM action . memoRead . editor where- editor r = do- q <- extRef r k (0, ls)- es <- mkEditors ls $ sndLens `lensMap` q- return $ hcat- [ combobox (map fst ss) $ fstLens `lensMap` q- , cell (liftM fst $ readRef q) $ \i -> vcat [es !! j | j <- snd $ ss !! i]- ]- where- (ss, ls, Lens_ k) = adtLens-- mkEditors :: EffRef m => Elems xs -> Ref m (Elems xs) -> m [Widget m]- mkEditors ElemsNil _ = return []- mkEditors (ElemsCons _ xs) r = do- i <- adtEditor $ lHead `lensMap` r- is <- mkEditors xs $ lTail `lensMap` r- return $ i : is- where- lHead :: Lens' (Elems (Cons x xs)) x- lHead = lens get set where- get :: Elems (Cons x xs) -> x- get (ElemsCons a _) = a- set :: Elems (Cons x xs) -> x -> Elems (Cons x xs)- set (ElemsCons _ as) a = ElemsCons a as-- lTail :: Lens' (Elems (Cons x xs)) (Elems xs)- lTail = lens get set where- get :: Elems (Cons x xs) -> Elems xs- get (ElemsCons _ as) = as- set :: Elems (Cons x xs) -> Elems xs -> Elems (Cons x xs)- set (ElemsCons a _) as = ElemsCons a as--
+ src/LGtk/Backend/GLFW.hs view
@@ -0,0 +1,390 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+module LGtk.Backend.GLFW+ ( runWidget+ ) where++import Data.Char+import Data.Maybe+--import Control.Applicative+import Control.Concurrent+import Control.Monad+import Control.Monad.Fix+--import Control.Lens hiding ((#))+import Foreign+import System.IO+import Graphics.Rendering.OpenGL.Raw.Core31+import Graphics.UI.GLFW hiding (Key (..), ModifierKeys (..))+import qualified Graphics.UI.GLFW as GLFW++import Diagrams.Prelude hiding (Image)++-- Rasterific+--import Diagrams.Backend.Rasterific++-- Cairo+import Diagrams.Backend.Cairo.Internal+import Graphics.Rendering.Cairo ( Format (..)+ , formatStrideForWidth+ , renderWith+ , withImageSurfaceForData+ )++import Data.LensRef+import Data.LensRef.Default+import LGtk.Effects+import LGtk.Widgets+import LGtk.Render+import LGtk.Key++-------------------------------++runRegister' :: Wrap (Register IO) a -> IO (a, IO ())+runRegister' (Wrap m) = runRegister newChan' m++runWidget :: (forall m . (EffIORef m, MonadFix m) => Widget m) -> IO ()+runWidget desc = do+ hSetBuffering stdout NoBuffering++ (widget, actions) <- runRegister' $ runWidget_ $ inCanvas 800 600 30 desc+ _ <- forkIO actions++ case widget of+ SWidget width height sc_ handle keyhandle current iodia -> do++ _ <- GLFW.init+-- print =<< getVersion+ Just win <- createWindow width height "Diagrams + GLFW" Nothing Nothing+ makeContextCurrent (Just win) -- for OpenGL++ exit <- newMVar False+ postedActions <- newMVar $ return ()+ mc <- newMVar (0, Nothing)+ current' <- newMVar mempty++ let+ post :: IO () -> IO ()+ post m = modifyMVar_ postedActions $ \n -> return $ n >> m++ dims = do+ (w, h) <- getFramebufferSize win+ let (w', h') = (fromIntegral w, fromIntegral h)+ let sc = w' / sc_+ return (sc, w', h', w, h)++ calcMousePos (x,y) = do+ (sc, w, h, _, _) <- dims+ d <- readMVar current'+ let p = p2 ((x - w / 2) / sc, (h / 2 - y) / sc)+ q = MousePos p $ d `sample` p+ return (q, d)++ logMousePos :: CursorPosCallback+ logMousePos _win x y = do+ t <- modifyMVar mc $ \(tick, _) -> return ((tick+1, Just (x,y)), tick+1)+ post $ do+ (t',q) <- readMVar mc+ case q of+ Just q | t==t' -> do+ calcMousePos q >>= \(q,d) -> handle (MoveTo q, d)+ _ -> return ()++ logMouseButton :: MouseButtonCallback+ logMouseButton _win _button state _mod = post $ do+ --putStrLn $ "MouseButtonCallback: " ++ show (button,state,mod)+ (_, p) <- readMVar mc+ case (state, p) of+ (MouseButtonState'Pressed, Just p) -> calcMousePos p >>= \(q,d) -> handle (Click q, d)+ (MouseButtonState'Released, Just p) -> calcMousePos p >>= \(q,d) -> handle (Release q, d)+ _ -> return ()++ logKey :: KeyCallback+ logKey _win key _scancode action mods = do+ when (key == GLFW.Key'Escape) $ swapMVar exit True >> return ()+ -- putStrLn $ "KeyCallback: " ++ show (action, key,mods)+ post $ when (action `elem` [KeyState'Pressed, KeyState'Repeating]) $ keyhandle $ trKey mods key++ logWinSize :: WindowSizeCallback+ logWinSize _win _w _h = do+ _ <- tryTakeMVar iodia+ current >>= putMVar iodia++ -- callbacks+ setKeyCallback win (Just logKey)+ setMouseButtonCallback win (Just logMouseButton)+ setCursorPosCallback win (Just logMousePos)+ setWindowSizeCallback win (Just logWinSize)+ setWindowCloseCallback win $ Just $ \_ -> swapMVar exit True >> return ()++ let redraw = do+ dia_ <- tryTakeMVar iodia+ case dia_ of+ Nothing -> return ()+ Just dia_ -> do+ (sc, w, h, sw, sh) <- dims+ let dia = dia_ # clearValue # freeze # scale sc # clipped (rect w h) <>+ rect w h # fc white # lw 0++ -- Rasterific+ --let sizeSpec = mkSizeSpec (Just $ fromIntegral w) (Just $ fromIntegral h)+ --let image = renderDia Rasterific (RasterificOptions sizeSpec) dia++ -- Cairo+ image <- createImage win sw sh dia+ copyImage (image,Rect 0 0 sw sh) (Screen win,Rect 0 sh sw 0)+ disposeImage image++ swapBuffers win+-- putStr "*"++ _ <- swapMVar current' dia_+ return ()++ let eventCycle = do+ pollEvents+ b <- readMVar exit+ when (not b) $ do+ join $ swapMVar postedActions $ return ()+ redraw+ threadDelay 10000+ eventCycle++ eventCycle+ destroyWindow win+ terminate+++trKey :: GLFW.ModifierKeys -> GLFW.Key -> ModifiedKey+trKey (GLFW.ModifierKeys s c a sup) k = ModifiedKey s c a sup $ case k of+ GLFW.Key'Space -> Key'Char ' '+ GLFW.Key'Apostrophe -> Key'Char '\''+ GLFW.Key'Comma -> Key'Char ','+ GLFW.Key'Minus -> Key'Char '-'+ GLFW.Key'Period -> Key'Char '.'+ GLFW.Key'Slash -> Key'Char '/'+ GLFW.Key'0 -> Key'Char '0'+ GLFW.Key'1 -> Key'Char '1'+ GLFW.Key'2 -> Key'Char '2'+ GLFW.Key'3 -> Key'Char '3'+ GLFW.Key'4 -> Key'Char '4'+ GLFW.Key'5 -> Key'Char '5'+ GLFW.Key'6 -> Key'Char '6'+ GLFW.Key'7 -> Key'Char '7'+ GLFW.Key'8 -> Key'Char '8'+ GLFW.Key'9 -> Key'Char '9'+ GLFW.Key'Semicolon -> Key'Char ';'+ GLFW.Key'Equal -> Key'Char '='+ GLFW.Key'A -> key s 'a'+ GLFW.Key'B -> key s 'b'+ GLFW.Key'C -> key s 'c'+ GLFW.Key'D -> key s 'd'+ GLFW.Key'E -> key s 'e'+ GLFW.Key'F -> key s 'f'+ GLFW.Key'G -> key s 'g'+ GLFW.Key'H -> key s 'h'+ GLFW.Key'I -> key s 'i'+ GLFW.Key'J -> key s 'j'+ GLFW.Key'K -> key s 'k'+ GLFW.Key'L -> key s 'l'+ GLFW.Key'M -> key s 'm'+ GLFW.Key'N -> key s 'n'+ GLFW.Key'O -> key s 'o'+ GLFW.Key'P -> key s 'p'+ GLFW.Key'Q -> key s 'q'+ GLFW.Key'R -> key s 'r'+ GLFW.Key'S -> key s 's'+ GLFW.Key'T -> key s 't'+ GLFW.Key'U -> key s 'u'+ GLFW.Key'V -> key s 'v'+ GLFW.Key'W -> key s 'w'+ GLFW.Key'X -> key s 'x'+ GLFW.Key'Y -> key s 'y'+ GLFW.Key'Z -> key s 'z'+ GLFW.Key'LeftBracket -> Key'Char '['+ GLFW.Key'Backslash -> Key'Char '\\'+ GLFW.Key'RightBracket -> Key'Char ']'+-- GLFW.Key'GraveAccent -> Key'+-- GLFW.Key'World1 -> Key'+-- GLFW.Key'World2 -> Key'+ GLFW.Key'Escape -> Key'Escape+ GLFW.Key'Enter -> Key'Char '\n'+ GLFW.Key'Tab -> Key'Char '\t'+ GLFW.Key'Backspace -> Key'Backspace+ GLFW.Key'Insert -> Key'Insert+ GLFW.Key'Delete -> Key'Delete+ GLFW.Key'Right -> Key'Right+ GLFW.Key'Left -> Key'Left+ GLFW.Key'Down -> Key'Down+ GLFW.Key'Up -> Key'Up+ GLFW.Key'PageUp -> Key'PageUp+ GLFW.Key'PageDown -> Key'PageDown+ GLFW.Key'Home -> Key'Home+ GLFW.Key'End -> Key'End+{-+ GLFW.Key'CapsLock -> Key'+ GLFW.Key'ScrollLock -> Key'+ GLFW.Key'NumLock -> Key'+ GLFW.Key'PrintScreen -> Key'+ GLFW.Key'Pause -> Key'+ GLFW.Key'F1 -> Key'+ GLFW.Key'F2 -> Key'+ GLFW.Key'F3 -> Key'+ GLFW.Key'F4 -> Key'+ GLFW.Key'F5 -> Key'+ GLFW.Key'F6 -> Key'+ GLFW.Key'F7 -> Key'+ GLFW.Key'F8 -> Key'+ GLFW.Key'F9 -> Key'+ GLFW.Key'F10 -> Key'+ GLFW.Key'F11 -> Key'+ GLFW.Key'F12 -> Key'+ GLFW.Key'F13 -> Key'+ GLFW.Key'F14 -> Key'+ GLFW.Key'F15 -> Key'+ GLFW.Key'F16 -> Key'+ GLFW.Key'F17 -> Key'+ GLFW.Key'F18 -> Key'+ GLFW.Key'F19 -> Key'+ GLFW.Key'F20 -> Key'+ GLFW.Key'F21 -> Key'+ GLFW.Key'F22 -> Key'+ GLFW.Key'F23 -> Key'+ GLFW.Key'F24 -> Key'+ GLFW.Key'F25 -> Key'+ GLFW.Key'Pad0 -> Key'+ GLFW.Key'Pad1 -> Key'+ GLFW.Key'Pad2 -> Key'+ GLFW.Key'Pad3 -> Key'+ GLFW.Key'Pad4 -> Key'+ GLFW.Key'Pad5 -> Key'+ GLFW.Key'Pad6 -> Key'+ GLFW.Key'Pad7 -> Key'+ GLFW.Key'Pad8 -> Key'+ GLFW.Key'Pad9 -> Key'+ GLFW.Key'PadDecimal -> Key'+ GLFW.Key'PadDivide -> Key'+ GLFW.Key'PadMultiply -> Key'+ GLFW.Key'PadSubtract -> Key'+ GLFW.Key'PadAdd -> Key'+ GLFW.Key'PadEnter -> Key'+ GLFW.Key'PadEqual -> Key'+ GLFW.Key'LeftShift -> Key'+ GLFW.Key'LeftControl -> Key'+ GLFW.Key'LeftAlt -> Key'+ GLFW.Key'LeftSuper -> Key'+ GLFW.Key'RightShift -> Key'+ GLFW.Key'RightControl -> Key'+ GLFW.Key'RightAlt -> Key'+ GLFW.Key'RightSuper -> Key'+ GLFW.Key'Menu -> Key'+-}+ _ -> Key'Unknown+ where+ key False c = Key'Char c+ key True c = Key'Char $ toUpper c++newChan' = do+ ch <- newChan+ return (readChan ch, writeChan ch)++data SWidget = forall a . (Monoid a, Semigroup a)+ => SWidget Int Int Double ((MouseEvent a, Dia a) -> IO ()) (ModifiedKey -> IO ()) (IO (Dia a)) (MVar (Dia a))+++runWidget_+ :: forall m . (MonadRegister m, IO ~ EffectM m) => Widget m -> m SWidget+runWidget_ m = m >>= \i -> case i of+ Canvas w h sc_ me keyh r diaFun -> do+ rer <- liftIO' $ newMVar mempty+ rer' <- liftIO' $ newMVar mempty+ _ <- onChangeSimple r $ \b -> liftIO' $ do+ let d = diaFun b+ _ <- tryTakeMVar rer+ putMVar rer d+ _ <- swapMVar rer' d+ return ()++ handle <- registerCallback me+ keyhandle <- registerCallback (\key -> fromMaybe (\_ -> return False) keyh key >> return ())+ return $ SWidget w h sc_ handle keyhandle (readMVar rer') rer+++-----------------------+-- backend drawing operations++data Rect = Rect !Int !Int !Int !Int -- x1, y1, x2, y2++data Image+ = Screen+ { imgGLContext :: GLFW.Window+ }+ | Image+ { imgGLContext :: GLFW.Window+ , imgGLTextureObj :: GLuint+ , imgGLFramebufferObj :: GLuint+ }++createImage :: GLFW.Window -> Int -> Int -> Dia Any -> IO Image -- width height+createImage win width height dia = do+ makeContextCurrent (Just win)++ fbo <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo+ glBindFramebuffer gl_DRAW_FRAMEBUFFER fbo++ tex <- alloca $! \pto -> glGenTextures 1 pto >> peek pto++ glBindTexture gl_TEXTURE_2D tex+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $ fromIntegral gl_NEAREST+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $ fromIntegral gl_NEAREST++ -- render image with cairo backend+ let stride = formatStrideForWidth fmt width+ fmt = FormatRGB24+ size = stride * height+ allocaArray size $ \pixelData -> do+ let opt = CairoOptions+ { _cairoSizeSpec = Dims (fromIntegral width) (fromIntegral height)+ , _cairoOutputType = RenderOnly+ , _cairoBypassAdjust = False+ , _cairoFileName = ""+ }+ (_, r) = renderDia Cairo opt dia+ withImageSurfaceForData pixelData fmt width height stride (`renderWith` r)+ glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_RGBA) (fromIntegral width) (fromIntegral height) 0 (fromIntegral gl_BGRA) gl_UNSIGNED_BYTE pixelData++ glFramebufferTexture2D gl_DRAW_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D tex 0++ status <- glCheckFramebufferStatus gl_FRAMEBUFFER+ when (status /= gl_FRAMEBUFFER_COMPLETE) $+ putStrLn $ "incomplete framebuffer: " ++ show status+ return $ Image+ { imgGLContext = win+ , imgGLTextureObj = tex+ , imgGLFramebufferObj = fbo+ }++disposeImage :: Image -> IO ()+disposeImage img = do+ makeContextCurrent (Just $ imgGLContext img)+ Foreign.with (imgGLFramebufferObj img) $ glDeleteFramebuffers 1+ Foreign.with (imgGLTextureObj img) $ glDeleteTextures 1++copyImage :: (Image,Rect) -> (Image,Rect) -> IO ()+copyImage (srcImg,Rect srcX1 srcY1 srcX2 srcY2) (dstImg,Rect dstX1 dstY1 dstX2 dstY2)+ | imgGLContext srcImg /= imgGLContext dstImg =+ putStrLn "copyImage error: images are from different GL contexts"+ | otherwise = do+ makeContextCurrent (Just $ imgGLContext srcImg)+ glBindFramebuffer gl_READ_FRAMEBUFFER $ case srcImg of+ Screen {} -> 0+ Image {} -> imgGLFramebufferObj srcImg+ glBindFramebuffer gl_DRAW_FRAMEBUFFER $ case dstImg of+ Screen {} -> 0+ Image {} -> imgGLFramebufferObj dstImg+ let f = fromIntegral+ glBlitFramebuffer (f $ srcX1) (f $ srcY1) (f $ srcX2) (f $ srcY2)+ (f $ dstX1) (f $ dstY1) (f $ dstX2) (f $ dstY2)+ gl_COLOR_BUFFER_BIT gl_LINEAR
+ src/LGtk/Backend/Gtk.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+module LGtk.Backend.Gtk+ ( runWidget+ ) where++import Control.Category+import Control.Monad+import Control.Exception+import Control.Monad.State+import Control.Monad.Trans.Control+import Control.Concurrent+import Data.Maybe+import Data.List hiding (union)+import Prelude hiding ((.), id)++import Graphics.UI.Gtk hiding (Widget, Release, Modifier)+import qualified Graphics.UI.Gtk as Gtk++import Data.LensRef+import Data.LensRef.Default+import LGtk.Effects+import LGtk.Key+import LGtk.Widgets++import Diagrams.Prelude+import Diagrams.Backend.Cairo+import Diagrams.Backend.Cairo.Internal++-------------------------++runWidget :: (forall m . (EffIORef m, MonadFix m) => Widget m) -> IO ()+runWidget w = runWidget' runRegister' w++runRegister' :: IO () -> Wrap (Register IO) a -> IO (a, IO ())+runRegister' pa (Wrap m) = runRegister (newChan' pa) m+ where+ newChan' pa = do+ ch <- newChan+ return (pa >> readChan ch, writeChan ch)++{- |+Run a Gtk widget description.++The widget is shown in a window and the thread enters into the Gtk event cycle.+It leaves the event cycle when the window is closed.+-}+runWidget' :: (MonadRegister m, MonadBaseControl IO (EffectM m))+ => (forall a . IO () -> m a -> IO (a, IO ())) -> Widget m -> IO ()+runWidget' run desc = gtkContext $ \postGUISync -> do+ postActionsRef <- newMVar $ return ()+ let addPostAction m = modifyMVar_ postActionsRef $ \n -> return $ n >> m+ runPostActions = join $ modifyMVar postActionsRef $ \m -> return (return (), m)+ (widget, actions) <- run runPostActions $ do+ w <- runWidget_ addPostAction postGUISync desc+ liftIO' runPostActions+ return w+ _ <- forkIO $ actions+ return widget++gtkContext :: ((forall a . IO a -> IO a) -> IO SWidget) -> IO ()+gtkContext m = do+ _ <- unsafeInitGUIForThreadedRTS+ tid <- myThreadId+ let post :: forall a . IO a -> IO a+ post e = do+ tid' <- myThreadId+ if tid' == tid then e else postGUISync e+ c <- m post+ window <- windowNew+ set window [ containerBorderWidth := 10, containerChild := snd c ]+ _ <- window `on` deleteEvent $ liftIO mainQuit >> return False+ widgetShowAll window+ mainGUI++type SWidget = (IO (), Gtk.Widget)++-- | Run an @IO@ parametrized interface description with Gtk backend+runWidget_+ :: forall m . (MonadRegister m, MonadBaseControl IO (EffectM m))+ => (IO () -> IO ())+ -> (forall a . IO a -> IO a)+ -> Widget m+ -> m SWidget+runWidget_ post' post = toWidget+ where+ liftIO'' :: IO a -> m a+ liftIO'' = liftIO' . post++ -- type Receive n m k a = (RegionStatusChange -> n ()) -> m (a -> k ())+ reg :: Receive m a -> ((a -> IO ()) -> IO (RegionStatusChange -> IO ())) -> m (RegionStatusChange -> IO ())+ reg s f = do+ re <- registerCallback s+ u <- liftEffectM $ liftBaseWith $ \unr -> f $ \x -> do+ _ <- unr $ re x+ return ()+ onRegionStatusChange (liftIO'' . u $)+ return u++ ger :: Eq a => (RegionStatusChange -> IO ()) -> RefReader m a -> (a -> IO ()) -> m ()+ ger hd s f = liftM (const ()) $ onChangeSimple s $ \a -> liftIO'' $ do+ hd Block+ f a+ hd Unblock++ nhd :: RegionStatusChange -> IO ()+ nhd = const $ return ()++ toWidget :: Widget m -> m SWidget+ toWidget m = m >>= \i -> case i of++ Label s -> do+ w <- liftIO'' $ labelNew Nothing+ ger nhd s $ labelSetLabel w+ return' w++ Canvas w h sc_ me keyh r diaFun -> mkCanvas me r diaFun where++ mkCanvas+ :: forall b da+ . (Monoid da, Semigroup da, Eq b)+ => ((MouseEvent da, Dia da) -> Modifier m ())+ -> RefReader m b+ -> (b -> Dia da)+ -> m SWidget+ mkCanvas me r diaFun = do++ cur <- liftIO' $ newMVar Nothing+ cur' <- liftIO' $ newMVar Nothing+ v <- liftIO' newEmptyMVar++ (canvasDraw, canvas, af, dims, drawingAreaGetDrawWindow') <- liftIO'' $ do+ canvas <- drawingAreaNew+ widgetAddEvents canvas [PointerMotionMask, KeyPressMask]+ widgetSetCanFocus canvas True+ af <- aspectFrameNew 0.5 0.5 (Just $ fromIntegral w / fromIntegral h)+ _ <- canvas `onSizeRequest` return (Requisition w h)+ _ <- containerAdd af canvas+ realized <- newMVar False+ _ <- onRealize canvas $ swapMVar realized True >> return ()+-- _ <- afterRealize canvas $ swapMVar realized False >> return ()+ let+ drawingAreaGetDrawWindow' = do+ b <- readMVar realized+ if b then catchJust select (liftM Just $ widgetGetDrawWindow canvas) (const $ return Nothing)+ else return Nothing+ where+ select :: SomeException -> Maybe ()+ select s | "widgetGetDrawWindow" `isInfixOf` show s = Just ()+ select _ = Nothing+ ++ dims win = do+ (w, h) <- drawableGetSize win+ let (w', h') = (fromIntegral w, fromIntegral h)+ let sc = w' / sc_+ return (sc, w', h', w, h)++ tr sc w h dia = translate (r2 (w/2, h/2)) $ dia # scaleY (-1) # scale sc `atop` rect w h # fc white # lw 0++ draw dia_ = do+ _ <- swapMVar cur $ Just dia_+ let dia = freeze $ clearValue dia_+ win <- drawingAreaGetDrawWindow'+ case win of+ Nothing -> return ()+ Just win -> do+ (sc, w, h, wi, he) <- dims win+ drawWindowBeginPaintRect win $ Rectangle 0 0 wi he+ renderWithDrawable win $ snd $ renderDia Cairo (CairoOptions "" (Width w) RenderOnly True) $ tr sc w h dia+ drawWindowEndPaint win++ return (draw, canvas, af, dims, drawingAreaGetDrawWindow')++ let -- compCoords :: (Double, Double) -> IO (MousePos a)+ compCoords_ (x,y) = do+ win <- drawingAreaGetDrawWindow'+ case win of+ Nothing -> return Nothing+ Just win -> do+ (sc, w, h, _, _) <- dims win+ d <- readMVar cur+ let p = p2 ((x - w / 2) / sc, (h / 2 - y) / sc)+ return $ Just (MousePos p $ maybe mempty (`sample` p) d, fromMaybe mempty d)++ _ <- reg me $ \re -> do+ let compCoords :: MonadIO em+ => em (Double, Double)+ -> ((MousePos da, Dia da) -> (MouseEvent da, Dia da))+ -> em ()+ compCoords eventCoordinates f = do+ c <- eventCoordinates+ liftIO $ compCoords_ c >>= maybe (return ()) (re . f)++ _ <- on' canvas buttonPressEvent $ tryEvent $ compCoords eventCoordinates $ \(p, d) -> (Click p, d)+ _ <- on' canvas buttonReleaseEvent $ tryEvent $ compCoords eventCoordinates $ \(p, d) -> (Release p, d)+ _ <- on' canvas enterNotifyEvent $ tryEvent $ compCoords eventCoordinates $ \(p, d) -> (MouseEnter p, d)+ _ <- on' canvas leaveNotifyEvent $ tryEvent $ compCoords eventCoordinates $ \(p, d) -> (MouseLeave p, d)+ _ <- on' canvas motionNotifyEvent $ tryEvent $ compCoords eventCoordinates $ \(p, d) -> (MoveTo p, d)+ on' canvas scrollEvent $ tryEvent $ do+ dir <- eventScrollDirection+ let tr _ = Horizontal -- TODO+ compCoords eventCoordinates $ \(p, d) -> (ScrollTo (tr dir) p, d)++ case keyh of+ Nothing -> return ()+ Just keyh -> do+ _ <- reg (\k -> keyh k >> return ()) $ \re ->+ on' canvas keyPressEvent $ tryEvent $ do+ m <- eventModifier+ c <- eventKeyVal+ kn <- lift $ keyvalName c+ kc <- lift $ keyvalToChar c+ liftIO $ re $ trKey m kn kc+ return ()++ _ <- liftIO' $ on canvas exposeEvent $ tryEvent $ liftIO $ do+ d <- readMVar cur'+ case d of+ Just x -> putMVar v x+ _ -> return ()++ canvasDraw' <- liftIO' $ do+ v2 <- newMVar False+ _ <- forkIO $ do+ threadDelay 200000+ forever $ do+ threadDelay 10000+ dia <- takeMVar v+ _ <- swapMVar cur' $ Just dia+ _ <- swapMVar v2 True+ let d = diaFun dia+ post $ canvasDraw d+ _ <- swapMVar v2 False+ return ()+ return $ \dia -> do+ b <- readMVar v2+ unless b $ do+ _ <- tryTakeMVar v+ putMVar v dia++ ger nhd r canvasDraw'+ return' af++ Button s sens col m -> do+ w <- liftIO'' buttonNew+ hd <- reg m $ \re -> on' w buttonActivated $ re ()+ ger hd s $ buttonSetLabel w+ ger hd sens $ widgetSetSensitive w+ let tr col = case toSRGB col of RGB r g b -> Color (f r) (f g) (f b)+ f d = fromInteger $ min 65535 $ max 0 $ floor $ d * 65536+ case col of+ Nothing -> return ()+ Just col -> ger hd col $ \c -> do+ widgetModifyBg w StateNormal $ tr c+ widgetModifyBg w StatePrelight $ tr c+ return' w+ Entry _ (r, s) -> do -- TODO: red background if not ok+ w <- liftIO'' entryNew+ hd <- reg s $ \re -> on' w entryActivate $ entryGetText w >>= re+ hd' <- reg s $ \re -> on' w focusOutEvent $ lift $ entryGetText w >>= re >> return False+ ger (\x -> hd x >> hd' x) r $ entrySetText w+ return' w+ Checkbox (r, s) -> do+ w <- liftIO'' checkButtonNew+ hd <- reg s $ \re -> on' w toggled $ toggleButtonGetActive w >>= re+ ger hd r $ toggleButtonSetActive w+ return' w+ Scale a b c (r, s) -> do+ w <- liftIO'' $ hScaleNewWithRange a b c+ _ <- liftIO'' $ w `onSizeRequest` return (Requisition 200 40)+ hd <- reg s $ \re -> on' w valueChanged $ rangeGetValue w >>= re+ ger hd r $ rangeSetValue w+ return' w+ Combobox ss (r, s) -> do+ w <- liftIO'' comboBoxNewText+ _ <- liftIO'' $ w `onSizeRequest` return (Requisition 100 30)+ liftIO'' $ flip mapM_ ss $ comboBoxAppendText w+ hd <- reg s $ \re -> on' w changed $ fmap (max 0) (comboBoxGetActive w) >>= re+ ger hd r $ comboBoxSetActive w+ return' w+ List o xs -> do+ ws <- mapM toWidget xs+ w <- liftIO'' $ case o of+ Vertical -> fmap castToBox $ vBoxNew False 1+ Horizontal -> fmap castToBox $ hBoxNew False 1+ shs <- forM ws $ liftIO'' . containerAdd'' w . snd+ liftM (mapFst (sequence_ shs >>)) $ return'' ws w+ Notebook' s xs -> do+ ws <- mapM (toWidget . snd) xs+ w <- liftIO'' notebookNew+ forM_ (zip ws xs) $ \(ww, (s, _)) -> do+ liftIO'' . flip (notebookAppendPage w) s $ snd $ ww+ _ <- reg s $ \re -> on' w switchPage $ re+ return'' ws w+ Cell onCh f -> do+ let b = False+ w <- liftIO'' $ case b of+ True -> fmap castToContainer $ hBoxNew False 1+ False -> fmap castToContainer $ alignmentNew 0 0 1 1+ sh <- liftIO' $ newMVar $ return ()+ _ <- onChange onCh $ \bv -> do+ mx <- f toWidget bv+ return $ mx >>= \(x,y) -> liftIO'' $ do + _ <- swapMVar sh x+ containerForeach w $ if b then widgetHideAll else containerRemove w + post' $ post $ do+ ch <- containerGetChildren w+ when (y `notElem` ch) $ containerAdd w y+ x+ liftM (mapFst (join (readMVar sh) >>)) $ return'' [] w++on' :: GObjectClass x => x -> Signal x c -> c -> IO (RegionStatusChange -> IO ())+on' o s c = liftM (flip f) $ on o s c where+ f Kill = signalDisconnect+ f Block = signalBlock+ f Unblock = signalUnblock++return' :: Monad m => WidgetClass x => x -> m SWidget+return' w = return (widgetShowAll w, castToWidget w)++return'' :: Monad m => WidgetClass x => [SWidget] -> x -> m SWidget+return'' ws w = return (mapM_ fst ws >> widgetShow w, castToWidget w)++mapFst f (a, b) = (f a, b)++containerAdd'' w x = do+ a <- alignmentNew 0 0 0 0+ containerAdd a x+ containerAdd w a+ set w [ boxChildPacking a := PackNatural ]+ return $ widgetShow a++trKey mods name ch+ = ModifiedKey (Gtk.Shift `elem` mods) (Gtk.Control `elem` mods) (Gtk.Alt `elem` mods) (Gtk.Super `elem` mods) k+ where+ k = case ch of+ Just c -> Key'Char c+ _ -> case name of+ "Escape" -> Key'Escape+ "BackSpace" -> Key'Backspace+ "Insert" -> Key'Insert+ "Delete" -> Key'Delete+ "Right" -> Key'Right+ "Left" -> Key'Left+ "Down" -> Key'Down+ "Up" -> Key'Up+ "PageUp" -> Key'PageUp+ "PageDown" -> Key'PageDown+ "Home" -> Key'Home+ "End" -> Key'End+ "Return" -> Key'Char '\n'+ "Tab" -> Key'Char '\t'+ _ -> Key'Unknown++
− src/LGtk/Demos/IntListEditor.hs
@@ -1,90 +0,0 @@--- | An integer list editor-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-module LGtk.Demos.IntListEditor where--import Control.Monad-import Data.List (sortBy)-import Data.Function (on)--import Data.Lens.Common-import LGtk--intListEditor- :: forall m a- . (EffRef m, Read a, Show a, Integral a)- => (a, Bool) -- ^ default element- -> Int -- ^ maximum number of elements- -> Ref m [(a, Bool)] -- ^ state reference- -> Ref m Bool -- ^ settings reference- -> Widget m-intListEditor def maxi list_ range = action $ do- (undo, redo) <- undoTr ((==) `on` map fst) list_- return $ notebook- [ (,) "Editor" $ vcat- [ hcat- [ entryShow len- , smartButton (return "+1") len (+1)- , smartButton (return "-1") len (+(-1))- , smartButton (liftM (("DeleteAll " ++) . show) $ readRef len) len $ const 0- , button (return "undo") undo- , button (return "redo") redo- ]- , hcat- [ smartButton (return "+1") list $ map $ modL fstLens (+1)- , smartButton (return "-1") list $ map $ modL fstLens (+(-1))- , smartButton (return "sort") list $ sortBy (compare `on` fst)- , smartButton (return "SelectAll") list $ map $ setL sndLens True- , smartButton (return "SelectPos") list $ map $ \(a,_) -> (a, a>0)- , smartButton (return "SelectEven") list $ map $ \(a,_) -> (a, even a)- , smartButton (return "InvertSel") list $ map $ modL sndLens not- , smartButton (liftM (("DelSel " ++) . show . length) sel) list $ filter $ not . snd- , smartButton (return "CopySel") safeList $ concatMap $ \(x,b) -> (x,b): [(x,False) | b]- , smartButton (return "+1 Sel") list $ map $ mapSel (+1)- , smartButton (return "-1 Sel") list $ map $ mapSel (+(-1))- ]- , label $ liftM (("Sum: " ++) . show . sum . map fst) sel- , action $ listEditor def (map itemEditor [0..]) list_- ]- , (,) "Settings" $ hcat- [ label $ return "Create range"- , checkbox range- ]- ]- where- list = eqRef list_-- itemEditor i r = return $ hcat- [ label $ return $ show (i+1) ++ "."- , entryShow $ fstLens `lensMap` r- , checkbox $ sndLens `lensMap` r- , button_ (return "Del") (return True) $ modRef list $ \xs -> take i xs ++ drop (i+1) xs- , button_ (return "Copy") (return True) $ modRef list $ \xs -> take (i+1) xs ++ drop i xs- ]-- safeList = lens id (const $ take maxi) `lensMap` list-- sel = liftM (filter snd) $ readRef list-- len = joinRef $ liftM (\r -> ll r `lensMap` safeList) $ readRef range- ll :: Bool -> Lens' [(a, Bool)] Int- ll r = lens length extendList where- extendList xs n = take n $ (reverse . drop 1 . reverse) xs ++- (uncurry zip . (iterate (+ if r then 1 else 0) *** repeat)) (head $ reverse xs ++ [def])-- mapSel f (x, y) = (if y then f x else x, y)-- (f *** g) (a, b) = (f a, g b)--listEditor :: EffRef m => a -> [Ref m a -> m (Widget m)] -> Ref m [a] -> m (Widget m)-listEditor def (ed: eds) r = do- q <- extRef r listLens (False, (def, []))- return $ cell (liftM fst $ readRef q) $ \b -> case b of- False -> empty- True -> action $ do- t1 <- ed $ sndLens . fstLens `lensMap` q- t2 <- listEditor def eds $ sndLens . sndLens `lensMap` q- return $ vcat [t1, t2]---
− src/LGtk/Demos/Main.hs
@@ -1,164 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-module LGtk.Demos.Main- ( main- ) where--import Data.Maybe (isJust)-import Data.Lens.Common-import Control.Monad--import LGtk--import LGtk.Demos.Tri-import LGtk.Demos.IntListEditor-import LGtk.Demos.TEditor--main :: IO ()-main = runWidget $ notebook- [ (,) "Hello" $ label $ return "Hello World!"-- , (,) "Counters" $ notebook-- [ (,) "Unbounded" $ action $ do- c <- newEqRef 0- return $ vcat- [ label $ liftM show $ readRef c- , hcat- [ smartButton (return "+1") c (+1)- , smartButton (return "-1") c (+(-1))- ]- ]-- , (,) "1..3" $ action $ do- c <- newEqRef 1- return $ vcat- [ label $ liftM show $ readRef c- , hcat- [ smartButton (return "+1") c $ min 3 . (+1)- , smartButton (return "-1") c $ max 1 . (+(-1))- ]- ]-- , (,) "a..b" $ action $ do- ab <- newRef (1, 3)- let (a, b) = interval ab- c <- counter 0 ab- return $ vcat- [ label $ liftM show $ readRef c- , hcat- [ smartButton (return "+1") c (+1)- , smartButton (return "-1") c (+(-1))- ]- , hcat [ label $ return "min", entryShow a ]- , hcat [ label $ return "max", entryShow b ]- ]-- ]-- , (,) "Buttons" $ action $ do- x <- newRef 0- let is = [0, 65535 `div` 2, 65535]- colorlist = liftM3 Color is is is- f n = colorlist !! (n `mod` length colorlist)- return $ button__ (return "Push") (return True) (liftM f $ readRef x) $ modRef x (+1)-- , (,) "Tabs" $ notebook-- [ (,) "TabSwitch" $ action $ do- x <- newRef "a"- let w = vcat [ label $ readRef x, entry x ]- return $ notebook- [ (,) "T1" w- , (,) "T2" w- ]-- ]-- , (,) "Async" $ action $ do- ready <- newRef True- delay <- newRef 1.0- onChange False (readRef ready) $ \b -> return $ case b of- True -> return ()- False -> do- d <- readRef' delay- asyncWrite (ceiling $ 10^6 * d) (writeRef ready) True- return $ vcat- [ hcat [ entryShow delay, label $ return "sec" ]- , button_ (readRef delay >>= \d -> return $ "Start " ++ show d ++ " sec computation")- (readRef ready)- (writeRef ready False)- , label $ liftM (\b -> if b then "Ready." else "Computing...") $ readRef ready- ]-- , (,) "Timer" $ action $ do- t <- newRef 0- onChange True (readRef t) $ \ti -> return $ asyncWrite (10^6) (writeRef t) (1 + ti) - return $ vcat- [ label $ liftM show $ readRef t- ]-- , (,) "System" $ notebook-- [ (,) "Args" $ action $ getArgs >>= \args -> return $ label $ return $ unlines args-- , (,) "ProgName" $ action $ getProgName >>= \args -> return $ label $ return args-- , (,) "Env" $ action $ do- v <- newRef "HOME"- return $ vcat- [ entry v- , label $ readRef v >>= liftM (maybe "Not in env." show) . lookupEnv - ]-- , (,) "Std I/O" $ let- put = action $ do- x <- newRef ""- onChange False (readRef x) $ return . putStrLn_- return $ hcat - [ label $ return "putStrLn"- , entry x- ]- get = action $ do- ready <- newRef $ Just ""- onChange False (liftM isJust $ readRef ready) $ \b -> - return $ when (not b) $ getLine_ $ writeRef ready . Just- return $ hcat - [ button_ (return "getLine") (liftM isJust $ readRef ready) $ writeRef ready Nothing- , label $ liftM (maybe "<<<waiting for input>>>" id) $ readRef ready- ]- in vcat [ put, put, put, get, get, get ]- ]-- , (,) "IntListEditor" $ action $ do- state <- fileRef "intListEditorState.txt"- list <- extRef (justLens "" `lensMap` state) showLens []- settings <- fileRef "intListEditorSettings.txt"- range <- extRef (justLens "" `lensMap` settings) showLens True- return $ intListEditor (0, True) 15 list range-- , (,) "Tri" tri-- , (,) "T-Editor1" tEditor1-- , (,) "T-Editor3" $ action $ newRef (iterate (Node Leaf) Leaf !! 10) >>= tEditor3-- ]--justLens :: a -> Lens' (Maybe a) a-justLens a = lens (maybe a id) (flip $ const . Just)--counter :: forall m a . (EffRef m, Ord a) => a -> Ref m (a, a) -> m (EqRef (Ref m) a)-counter x ab = do- c <- extRef ab (fix . sndLens) (x, (x, x))- return $ fix . fstLens `lensMap` eqRef c- where- fix :: Lens' (a, (a,a)) (a, (a,a))- fix = lens id $ \_ (x, ab@(a, b)) -> (min b $ max a x, ab)--interval :: (Reference r, Ord a) => r (a, a) -> (r a, r a)-interval ab = (lens fst set1 `lensMap` ab, lens snd set2 `lensMap` ab) where- set1 (_, b) a = (min b a, b)- set2 (a, _) b = (a, max a b)--
− src/LGtk/Demos/TEditor.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}-module LGtk.Demos.TEditor where--import Data.Lens.Common-import Control.Monad-import LGtk-import LGtk.ADTEditor---- | Binary tree shapes-data T- = Leaf- | Node T T- deriving Show---- | Lens for @T@-tLens :: Lens' (Bool, (T, T)) T-tLens = lens get set where- get (False, _) = Leaf- get (True, (l, r)) = Node l r- set (_, x) Leaf = (False, x)- set _ (Node l r) = (True, (l, r))---- | @ADTLens@ instance for @T@-instance ADTLens T where- type ADTEls T = Cons T (Cons T Nil)- adtLens = ([("Leaf",[]),("Node",[0,1])], ElemsCons Leaf (ElemsCons Leaf ElemsNil), Lens_ $ lens get set) where- get :: (Int, Elems (ADTEls T)) -> T- get (0, _) = Leaf- get (1, ElemsCons l (ElemsCons r ElemsNil)) = Node l r- set :: (Int, Elems (ADTEls T)) -> T -> (Int, Elems (ADTEls T))- set (_, x) Leaf = (0, x)- set _ (Node l r) = (1, ElemsCons l (ElemsCons r ElemsNil))---- | @T@ editor with comboboxes, as an ADTEditor-tEditor1 :: EffRef m => Widget m-tEditor1 = action $ newRef Leaf >>= adtEditor---- | @T@ editor with checkboxes, given directly-tEditor3 :: EffRef m => Ref m T -> m (Widget m)-tEditor3 r = do- q <- extRef r tLens (False, (Leaf, Leaf))- return $ hcat- [ checkbox $ fstLens `lensMap` q- , cell (liftM fst $ readRef q) $ \b -> case b of- False -> empty- True -> action $ do- t1 <- tEditor3 $ sndLens . fstLens `lensMap` q- t2 <- tEditor3 $ sndLens . sndLens `lensMap` q- return $ vcat [t1, t2]- ]--
− src/LGtk/Demos/Tri.hs
@@ -1,39 +0,0 @@-{- |-An editor for integers x, y, z such that x + y = z always hold and-the last edited value change.--}-module LGtk.Demos.Tri where--import Data.Lens.Common-import LGtk---- | Information pieces: what is known?-data S = X Int | Y Int | XY Int---- | Getter-getX, getY, getXY :: [S] -> Int-getX s = head $ [x | X x <- s] ++ [getXY s - getY s]-getY s = head $ [x | Y x <- s] ++ [getXY s - getX s]-getXY s = head $ [x | XY x <- s] ++ [getX s + getY s]---- | Setter-setX, setY, setXY :: [S] -> Int -> [S]-setX s x = take 2 $ X x : filter (\x-> case x of X _ -> False; _ -> True) s-setY s x = take 2 $ Y x : filter (\x-> case x of Y _ -> False; _ -> True) s-setXY s x = take 2 $ XY x : filter (\x-> case x of XY _ -> False; _ -> True) s---- | The editor-tri :: EffRef m => Widget m-tri = action $ do- s <- newRef [X 0, Y 0]- return $ vcat- [ hcat [entryShow $ lens getX setX `lensMap` s, label $ return "x"]- , hcat [entryShow $ lens getY setY `lensMap` s, label $ return "y"]- , hcat [entryShow $ lens getXY setXY `lensMap` s, label $ return "x + y"]- ]------
+ src/LGtk/Effects.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+module LGtk.Effects where++--import Control.Applicative+import Control.Concurrent+import Control.Exception (evaluate)+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Operational+--import Control.Monad.Reader+import Control.Monad.Trans.Control+import System.Directory+import qualified System.FilePath as F+import System.FSNotify+import Filesystem.Path hiding (FilePath)+import Filesystem.Path.CurrentOS hiding (FilePath)+import qualified System.Environment as Env+import System.IO.Error (catchIOError, isDoesNotExistError)++import Data.LensRef+++--------------------------------------------------------------------------++-- | Type class for IO actions.+class MonadRegister m => EffIORef m where++ -- | The program's command line arguments (not including the program name). + getArgs :: m [String]++ -- | The name of the program as it was invoked.+ getProgName :: m String++ -- | @(lookupEnv var)@ returns the value of the environment variable @var@.+ lookupEnv :: String -> m (Maybe String)++ {- |+ @(asyncWrite t f a)@ has the effect of doing @(f a)@ after waiting @t@ milliseconds.++ Note that @(asyncWrite 0 f a)@ acts immediately after the completion of the current computation,+ so it is safe, because the effect of @(f a)@ is not interleaved with+ the current computation.+ Although @(asyncWrite 0)@ is safe, code using it has a bad small.+ -}+ asyncWrite :: Int -> Modifier m () -> m ()++ {- |+ @(fileRef path)@ returns a reference which holds the actual contents+ of the file accessed by @path@.++ When the value of the reference changes, the file changes.+ When the file changes, the value of the reference changes.++ If the reference holds @Nothing@, the file does not exist.+ Note that you delete the file by putting @Nothing@ into the reference. ++ Implementation note: The references returned by @fileRef@ are not+ memoised so currently it is unsafe to call @fileRef@ on the same filepath more than once.+ This restriction will be lifted in the future.+ -}+ fileRef :: FilePath -> m (Ref m (Maybe String))+++ {- | Read a line from the standard input device.+ @(getLine_ f)@ returns immediately. When the line @s@ is read,+ @f s@ is called.+ -}+ getLine_ :: (String -> Modifier m ()) -> m ()++ -- | Write a string to the standard output device.+ putStr_ :: EffIORef m => String -> m ()++-- | @putStrLn_@ === @putStr_ . (++ "\n")@+putStrLn_ :: EffIORef m => String -> m ()+putStrLn_ = putStr_ . (++ "\n")+++newtype Wrap m a = Wrap { unWrap :: Modifier m a }-- deriving (Functor, Applicative, Monad)++--deriving instance MonadRegister m => Functor (Wrap m)+--deriving instance MonadRegister m => Applicative (Wrap m)+deriving instance MonadRegister m => Monad (Wrap m)++instance (MonadRegister m, MonadFix (Modifier m)) => MonadFix (Wrap m) where+ mfix f = Wrap $ mfix $ unWrap . f++instance (MonadRegister m) => MonadRefReader (Wrap m) where+ type BaseRef (Wrap m) = BaseRef m+ liftRefReader = Wrap . liftRefReader++instance MonadRegister m => MonadRefCreator (Wrap m) where+ extRef r l = Wrap . extRef r l+ newRef = Wrap . newRef++instance MonadRegister m => MonadMemo (Wrap m) where+ memoRead (Wrap m) = liftM Wrap $ Wrap $ memoRead m++instance MonadRegister m => MonadRefWriter (Wrap m) where+ liftRefWriter = Wrap . liftRefWriter+{-+deriving instance (MonadRegister m) => Monad (Modifier (Wrap m))++instance MonadRegister m => MonadRefReader (Modifier (Wrap m)) where+ type BaseRef (Modifier (Wrap m)) = BaseRef m+ liftRefReader = WrapM . liftRefReader++instance MonadRegister m => MonadMemo (Modifier (Wrap m)) where+ memoRead (WrapM m) = liftM WrapM $ WrapM $ memoRead m++instance MonadRegister m => MonadRefCreator (Modifier (Wrap m)) where+ extRef r l = WrapM . extRef r l+ newRef = WrapM . newRef++instance MonadRegister m => MonadRefWriter (Modifier (Wrap m)) where+ liftRefWriter = WrapM . liftRefWriter+-}+instance (MonadRegister m, MonadRegister (Modifier m)) => MonadRegister (Wrap m) where+ type EffectM (Wrap m) = EffectM m+ --newtype Modifier (Wrap m) a = WrapM { unWrapM :: Modifier m a}+ type Modifier (Wrap m) = Wrap m+ liftEffectM = Wrap . liftEffectM -- :: EffectM m a -> m a+ liftToModifier = id --WrapM . liftToModifier . unWrap -- :: m a -> Modifier m a+-- onChangeAcc r b bc f = Wrap $ onChangeAcc r b bc $ (fmap . fmap . fmap) (liftM (fmap unWrap) . unWrap) f+ onChange r f = Wrap $ onChange r $ fmap (liftM unWrap . unWrap) f+ onChangeSimple r f = Wrap $ onChangeSimple r $ fmap unWrap f+ registerCallback r = Wrap $ registerCallback (fmap unWrap r)+ onRegionStatusChange g = Wrap $ onRegionStatusChange $ unWrap . g++data IOInstruction a where+ GetArgs :: IOInstruction [String]+ GetProgName :: IOInstruction String+ LookupEnv :: String -> IOInstruction (Maybe String)+ PutStr :: String -> IOInstruction ()+ GetLine :: (String -> SIO ()) -> IOInstruction Handle + AsyncWrite :: Int -> SIO () -> IOInstruction Handle+ FileRef :: FilePath -> (Maybe String -> SIO ()) -> IOInstruction (Handle, String -> SIO ())++type SIO = Program IOInstruction++type Handle = RegionStatusChange -> SIO ()++instance (MonadRegister m, MonadRegister (Modifier m), MonadBaseControl IO (EffectM m)) => EffIORef (Wrap m) where++ getArgs = liftIO' Env.getArgs++ getProgName = liftIO' Env.getProgName++-- lookupEnv = Env.lookupEnv -- does not work with Haskell Platform 2013.2.0.0+ lookupEnv v = liftIO' $ catchIOError (liftM Just $ Env.getEnv v) $ \e ->+ if isDoesNotExistError e then return Nothing else ioError e++ asyncWrite t r = do+ (u, f) <- liftEffectM forkIOs'+ x <- registerCallback $ const r+ onRegionStatusChange $ liftEffectM . u+ liftEffectM $ f [ liftIO_ $ threadDelay t, x () ]++ fileRef f = do+ ms <- liftIO' r+ ref <- newRef ms+ v <- liftIO' newEmptyMVar+ vman <- liftIO' $ newMVar $ return ()+ cf <- liftIO' $ canonicalizePath' f+ let+ cf' = decodeString cf+ g = (== cf')++ h = tryPutMVar v () >> return ()++ filt (Added x _) = g x+ filt (Modified x _) = g x+ filt (Removed x _) = g x++ act (Added _ _) = h+ act (Modified _ _) = h+ act (Removed _ _) = h++ startm = do+ man <- startManager+ putMVar vman $ stopManager man+ watchDir man (directory cf') filt act++ (u, ff) <- liftEffectM forkIOs'+ re <- registerCallback (writeRef ref)+ onRegionStatusChange $ liftEffectM . u+ liftEffectM $ ff $ repeat $ liftIO_ (takeMVar v >> r) >>= re++ _ <- onChangeSimple (readRef ref) $ \x -> liftIO' $ do+ join $ takeMVar vman+ _ <- tryTakeMVar v+ w x+ threadDelay 10000+ startm+ return ref+ where+ r = do+ b <- doesFileExist f+ if b then do+ xs <- readFile f+ _ <- evaluate (length xs)+ return (Just xs)+ else return Nothing++ w = maybe (doesFileExist f >>= \b -> when b (removeFile f)) (writeFile f)++ getLine_ w = do+ (u, f) <- liftEffectM forkIOs'+ x <- registerCallback w+ onRegionStatusChange $ liftEffectM . u+ liftEffectM $ f [ liftIO_ getLine >>= x ] -- TODO+ putStr_ s = liftIO' $ putStr s++getLine__ :: (String -> IO ()) -> IO (RegionStatusChange -> IO ())+getLine__ f = do+ _ <- forkIO $ forever $ getLine >>= f -- todo+ return $ const $ return ()++-- canonicalizePath may fail if the file does not exsist+canonicalizePath' p = liftM (F.</> f) $ canonicalizePath d + where (d,f) = F.splitFileName p++liftIO' = liftEffectM . liftIO_++liftIO_ = liftBaseWith . const++forkIOs' :: MonadBaseControl IO m => m (RegionStatusChange -> m (), [m ()] -> m ())+forkIOs' = liftBaseWith $ \run -> do+ x <- newMVar ()+ s <- newEmptyMVar+ let g = do+ readMVar x+ is <- takeMVar s+ case is of+ [] -> return ()+ (i:is) -> do+ putMVar s is+ _ <- run i+ g+ f i Kill = killThread i+ f _ Block = takeMVar x+ f _ Unblock = putMVar x ()++ i <- forkIO g+ return (liftIO_ . f i, liftIO_ . putMVar s)++
+ src/LGtk/Key.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+-- | Lens-based Gtk interface+module LGtk.Key where++data Key+ = Key'Char Char+ | Key'Escape+ | Key'Backspace+ | Key'Insert+ | Key'Delete+ | Key'Right+ | Key'Left+ | Key'Down+ | Key'Up+ | Key'PageUp+ | Key'PageDown+ | Key'Home+ | Key'End+ | Key'Unknown+ deriving (Eq, Ord, Read, Show)++pattern Key'Tab = Key'Char '\t'+pattern Key'Enter = Key'Char '\n'+pattern Key'Space = Key'Char ' '++data ModifiedKey = ModifiedKey+ { modifierKeysShift :: Bool+ , modifierKeysControl :: Bool+ , modifierKeysAlt :: Bool+ , modifierKeysSuper :: Bool+ , theModifiedKey :: Key+ }+ deriving (Eq, Ord, Read, Show)++pattern SimpleKey k = ModifiedKey False False False False k+pattern ShiftKey k = ModifiedKey True False False False k+pattern ControlKey k = ModifiedKey False True False False k+pattern AltKey k = ModifiedKey False False True False k+pattern SuperKey k = ModifiedKey False False False True k++pattern CharKey c <- (getSimpleChar -> Just c)++getSimpleChar (SimpleKey (Key'Char c)) = Just c+getSimpleChar (ShiftKey (Key'Char c)) = Just c+getSimpleChar _ = Nothing+
+ src/LGtk/Render.hs view
@@ -0,0 +1,564 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RecursiveDo #-}+module LGtk.Render+ ( inCanvas+ ) where++import Control.Applicative hiding (empty)+import Control.Monad+import Control.Monad.State+import Control.Lens hiding ((#), beside)+import Data.List+import Data.Typeable+import Data.Maybe+import Diagrams.Prelude+--import Diagrams.BoundingBox+--import Graphics.SVGFonts+import Data.Colour.SRGB+import Unsafe.Coerce++import Data.LensRef+import LGtk.Key+import LGtk.Widgets++----------------------++pairs xs = zip xs (tail xs)+++-------------------------------------- Maybe type with another semigroup structure++data Maybe' a = Just' a | Nothing'++instance Semigroup (Maybe' a) where+ _ <> Just' a = Just' a+ a <> Nothing' = a++instance Monoid (Maybe' a) where+ mempty = Nothing'+ mappend = (<>)++instance Monad Maybe' where+ return = pure+ Just' x >>= f = f x+ _ >>= _ = Nothing'++instance Applicative Maybe' where+ pure = Just'+ Just' f <*> Just' x = Just' $ f x+ _ <*> _ = Nothing'++instance Functor Maybe' where+ fmap _ Nothing' = Nothing'+ fmap f (Just' x) = Just' $ f x++-------------------------------------- better clipBy++data X a = X a | Cancel | Z++instance Monoid (X a) where+ mempty = Z+ mappend = (<>)++instance Semigroup (X a) where+ x <> Z = x+ Z <> x = x+ _ <> Cancel = Cancel+ Cancel <> _ = Cancel++clipBy' p d = fmap unX (fmap X d # clipBy p # withEnvelope p <> fmap flipp (stroke p # lw 0 # value Cancel))+ where+ flipp Cancel = Z+ flipp Z = Cancel++ unX (X a) = a+ unX _ = mempty++--------------------------------------------------------- Identifiers++newtype Id = Id [Int]+ deriving (Eq, Ord, Show, Typeable)++type WithId = StateT Id++firstId :: Id+firstId = Id []++newId :: Monad m => WithId m Id+newId = do+ x@(Id (i:is)) <- get+ put $ Id $ i+1:is+ return x++newIds :: Monad m => Id -> WithId m a -> m a+newIds (Id i) = flip evalStateT $ Id (0:i)++instance IsName Id where++---------------------------------------------------------++-- how to handle keyboard events+type KeyHandler m = ModifiedKey -> m Bool++-- focus enter action; keyboard event handler; focus leave action; id of the keyboard-focused widget+type KeyFocusHandler m = (m (), KeyHandler m, m (), Id)++type CapturedEventHandler a m = (MouseEvent a, Dia a) -> m Bool++-- for each mouse event:+-- - what to do+-- - the new keyboard focus handler+-- - the id of the mouse-focused widget+type EventHandler a m = (MouseEvent a, Dia a) -> Maybe' (m (), Maybe (CapturedEventHandler a m), Maybe (KeyFocusHandler m), Id)++-- compiled widget+data CWidget m+ = forall a x . (Eq x, Monoid a, Semigroup a)+ => CWidget (RefReader m (([KeyFocusHandler m], [[KeyFocusHandler m]]), x)) (a -> EventHandler () m) (x -> [Id] -> Id -> Dia a)++------------------++value_ :: Monad m => m () -> KeyFocusHandler m -> Id -> Dia Any -> Dia (EventHandler () m)+value_ a c i = value $ valueFun a c i++valueFun a c i = f where+ f (Click _, _di) = Just' (a, Nothing, Just c, i)+ f (MoveTo _, _di) = Just' (return (), Nothing, Nothing, i)+ f _ = mempty++-----------------++[] !!! _ = Nothing+_ !!! n | n < 0 = Nothing+(x:_) !!! 0 = Just x+(_:xs) !!! n = xs !!! (n-1 :: Int)++[x] !!!! _ = x+(x:_) !!!! n | n <= 0 = x+(_:xs) !!!! n = xs !!!! (n-1 :: Int)++inCanvas :: forall m . (MonadRegister m, MonadFix m) => Int -> Int -> Double -> Widget m -> Widget m+inCanvas width height scale w = mdo++ let i = firstId++ foc <- newRef df+ rememberfoc <- newRef df++ -- captured event handler+ capt <- newRef Nothing++ -- mouse-focused widget id+ hi <- newRef [i]++ let df = (return (), dkh, return (), i)++ calcPos i jss = listToMaybe [(a,b) | (a,js) <- zip [0..] jss, (b, j) <- zip [0..] js, i == j]++ changeFoc f = do+ (_, _, _, j) <- readRef foc+ (_, xss_) <- liftRefReader bb+ let xss = filter (not . null) xss_+ if null xss+ then return False+ else do+ let mp = calcPos j $ map (map (\(_,_,_,i)->i)) xss+ ((a,_), (a',b')) = maybe ((0,0), (0,0)) (\x -> (x, f x)) mp+ if a == a'+ then maybe (return False) ((>> return True) . h2) $ (xss !! a') !!! b'+ else maybe (return False) ((>> return True) . h2) $ fmap (!!!! b') (xss !!! a')++ dkh (SimpleKey Key'Up) = changeFoc $ \(a,b) -> (a-1,b)+ dkh (SimpleKey Key'Down) = changeFoc $ \(a,b) -> (a+1,b)+ dkh (SimpleKey Key'Left) = changeFoc $ \(a,b) -> (a,b-1)+ dkh (SimpleKey Key'Right) = changeFoc $ \(a,b) -> (a,b+1)+ dkh (SimpleKey Key'Tab) = moveFoc True+ dkh (ControlKey Key'Tab) = moveFoc False+ dkh _ = return False++ h2 m@(a,_,_,i) = do+ i' <- readRef $ _4 `lensMap` foc+ when (i /= i') $ do+ join $ readRef $ _3 `lensMap` foc+ a+ writeRef foc m++ moveFoc f = do+ (_, _, _, j) <- readRef foc+ (xs, _) <- liftRefReader bb+ h2 $ maybe (head xs) snd $ find (\((_,_,_,x),_) -> x == j) $ pairs $ (if f then id else reverse) (xs ++ xs)+ return $ if f then j /= last xs ^. _4 else j /= head xs ^. _4++ -- compiled widget+ bhr <- newIds firstId $ tr (fromIntegral width / scale) dkh w++ let bb = case bhr of+ CWidget b _ _ -> liftM fst b++ case bhr of+ CWidget b hr render -> do+ + let handle_ Nothing' = writeRef hi [i] -- return ()+ handle_ (Just' (a, cap, bb, i)) = do+ a+ maybe (return ()) (writeRef capt . Just) cap+ maybe (return ()) h2 bb+ writeRef hi [i]+ return ()++ hr_ (Just' x) = hr x+ hr_ Nothing' = valueFun (return ()) df i++ handle f x = do+ m <- readRef capt+ case m of+ Nothing -> handle_ $ hr_ f x+ Just f -> do+ b <- f x+ when (not b) $ writeRef capt Nothing++ handleEvent (Release (MousePos p f), di) = handle f (Release $ MousePos p (), di # clearValue # value ())+ handleEvent (Click (MousePos p f), di) = handle f (Click $ MousePos p (), di # clearValue # value ())+ handleEvent (MoveTo (MousePos p f), di) = handle f (MoveTo $ MousePos p (), di # clearValue # value ())+ handleEvent (GetFocus, _di) = readRef rememberfoc >>= h2+ handleEvent (LostFocus, _di) = readRef foc >>= writeRef rememberfoc >> h2 df+ handleEvent _ = return ()++ handleKeys key = do+ (_,f,_,_) <- readRef foc+ f key++ return $ Canvas width height scale handleEvent (Just handleKeys) (liftM3 (,,) (readRef hi) (readRef $ _4 `lensMap` foc) $ liftM snd b) $+ \(is, is', x) -> + fmap Just' (render x is is' # alignT # alignL # translate (r2 (-scale/2,scale/2* fromIntegral height / fromIntegral width)))+ <> fmap (const Nothing') (rect scale (scale / fromIntegral width * fromIntegral height) # value ())++focWidth = 0.1++text__ :: Double -> Double -> String -> ((Double :& Double), Dia Any)+{-+text_ s = (coords $ boxExtents (boundingBox t) + r2 (0.2, 0.2) , t) where+ t = textSVG s 1.8 # stroke # fc black +-}+text__ ma mi s = ((max mi (min ma $ fromIntegral (length s) * 2/3) :& 1), text s)++defcolor = sRGB 0.95 0.95 0.95++tr :: forall m . MonadRegister m+ => Double+ -> KeyHandler (Modifier m)+ -> Widget m+ -> WithId m (CWidget (Modifier m))+tr sca dkh w = do+ w' <- lift w+ case w' of+ Label r -> do+ let render bv _ _ = ((rect x y # lw 0 <> te) # clipped (rect x y)) # value mempty+ where ((x :& y), te) = text__ 25 5 bv+ return $ CWidget (liftM ((,) ([], [])) r) id render++ Button r sens col a -> do+ i <- newId++ let ff (CharKey ' ') = a () >> return True+ ff (CharKey '\n') = a () >> return True+ ff k = dkh k+ kh = (return (), ff, return (), i)++ col' = maybe (return black) id col++ render (bv, se, color) is is' =+ (te # fc (if se then color else gray)+ <> roundedRect x y 0.3 # fc (if i `elem` is && se then yellow else defcolor)+ # (if is' == i && se then lc yellow . lw focWidth else lc black . lw 0.02)+ )+ # (if se then value_ (a ()) kh i else value mempty)+ # clipBy' (rect (x+0.1) (y+0.1)) # freeze # frame 0.1+ where ((x :& y), te) = text__ 15 3 bv+ return $ CWidget (liftM3 (\r se c -> (([kh | se], [[kh] | se]), (r,se,c))) r sens col') id render++ Entry isOk (rs, rr) -> do+ i <- newId+-- s <- readRef rs+ j <- lift $ newRef (False, ("", ""))++ let f (CharKey c) (a,b) = Just (c:a,b)+ f (SimpleKey Key'Backspace) (_:a,b) = Just (a,b)+ f (SimpleKey Key'Delete) (a,_:b) = Just (a,b)+ f (SimpleKey Key'Left) (c:a,b) = Just (a,c:b)+ f (SimpleKey Key'Right) (a,c:b) = Just (c:a,b)+ f _ _ = Nothing++ commit = do+ (_, ab) <- readRef j+ let s = value' ab+ old <- liftRefReader rs+ when (s /= old && isOk s) $ do+ rr s+ new <- liftRefReader rs+ update new++ update s = writeRef (_2 `lensMap` j) (reverse s, "")++ ff (CharKey '\n') = commit >> return True+ ff key = do+ x <- readRef (_2 `lensMap` j)+ case f key x of+ Just x -> writeRef (_2 `lensMap` j) x >> return True+ _ -> dkh key++ value' (a,b) = reverse a ++ b++ text' (False,ab) = value' ab+ text' (True,(a,b)) = reverse a ++ "|" ++ b+ isOk' (_,ab) = isOk $ value' ab++ kh = (fin, ff, fout, i)+ where+ fin = writeRef (_1 `lensMap` j) True+ fout = do+ commit+ writeRef (_1 `lensMap` j) False++ render (orig,bv) is is' = + ( te # clipped (rect x y) # value mempty+ <> rect x y # (if isOk' bv then (if i `elem` is then fc yellow else (if orig /= value' (snd bv) then fc defcolor else id)) else fc red)+ # (if is' == i then lc yellow . lw focWidth else lc black . lw 0.02)+ # value_ (return ()) kh i+ ) # freeze # frame 0.1+ where ((x :& y), te) = text__ 7 5 $ text' bv++ _ <- lift $ onChangeSimple rs $ postponeModification . update++ return $ CWidget (liftM ((,) ([kh],[[kh]])) (liftM2 (,) rs (readRef j))) id render++ Checkbox (bs, br) -> do+ i <- newId++ let ff (CharKey ' ') = liftRefReader bs >>= br . not >> return True+ ff k = dkh k+ kh = (return (), ff, return (), i)++ render bv is is' = + (+ (if bv then fromVertices [p2 (-0.3, 0), p2 (-0.1,-0.3), p2 (0.3,0.3)] + # lineCap LineCapRound else mempty) # value mempty # lw 0.15+ <> rect 1 1 # value_ (br (not bv)) kh i+ # fc (if i `elem` is then yellow else sRGB 0.95 0.95 0.95)+ # (if is' == i then lc yellow . lw focWidth else lc black . lw 0.02)+ ) # freeze # frame 0.1+ return $ CWidget (liftM ((,) ([kh],[[kh]])) bs) id render++ Cell r f -> do+ i <- newId+ r' <- lift $ onChange r $ \x -> do + h <- f (newIds i . tr sca dkh) x+ return $ do+ hv <- h+ return $ case hv of+ CWidget rr hr render -> do+ (es, rrv) <- rr+ return $ (es, UnsafeEqWrap (x, rrv) $ fmap (fmap (fmap hr)) $ render rrv)+ return $ CWidget (join r') id $ \(UnsafeEqWrap _ d) is is' -> d is is'++ List layout ws -> liftM (foldr conc2 nil) $ mapM (tr sca dkh) ws+ where+ nil :: MonadRefCreator n => CWidget n+ nil = CWidget (return (([],[]),())) id mempty++ conc2 (CWidget b hr r) (CWidget b' hr' r')+ = CWidget (liftM2 (\((a,a'),b)((c,c'),d)->((a++c,comb layout a' c'),(b,d))) b b') id (\(x,y) -> liftM2 (liftM2 ff) (fmap (fmap (fmap hr)) $ r x) (fmap (fmap (fmap hr')) $ r' y))++ comb Vertical = (++)+ comb Horizontal = fx++ fx (a:as) (b:bs) = (a++b): fx as bs+ fx as bs = as ++ bs++ ff = case layout of+ Horizontal -> \a b -> a # alignT ||| b # alignT+ Vertical -> \a b -> a # alignL === b # alignL++ Canvas w h d r keyh s f -> do++ i <- newId++ let ff key = do+ b <- fromMaybe (\_ -> return False) keyh key+ if b then return True else dkh key++ tr di p = case lookupName i di of+ Just subd -> p # translate (p2 (0,0) .-. q) # scale (1/((fromIntegral w / d) / sca))+ where q = location subd++-- decomp (x :& y) = (x,y)++ gg (Just' ls) (Click (MousePos p _), di) = Just' (r (Click $ MousePos (tr di p) ls, di # clearValue # value ls) >> return (), Nothing, Just kh, i)+ gg (Just' ls) (Release (MousePos p _), di) = Just' (r (Release $ MousePos (tr di p) ls, di # clearValue # value ls) >> return (), Nothing, Nothing, i)+ gg (Just' ls) (MoveTo (MousePos p _), di) = Just' (r (MoveTo $ MousePos (tr di p) ls, di # clearValue # value ls) >> return (), Nothing, Nothing, i)+ gg _ _ = mempty++ wi = fromIntegral w / sca+ hi = fromIntegral h / sca++ kh = (r (GetFocus, undefined) >> return (), ff, r (LostFocus, undefined) >> return (), i)++ render bv _is is' = (fmap gg (fmap Just' (f bv # freeze) # scale ((fromIntegral w / d) / sca)+ # clipBy' (rect wi hi))+ <> rect wi hi # named i # value mempty # lw 0.02 # lc (if is' == i then yellow else black)+ ) # freeze # frame 0.1++ return $ CWidget (liftM ((,) ([kh | isJust keyh],[[kh] | isJust keyh])) s) id render++ Combobox xs (bs, br) -> do+ let n = length xs+ iss <- replicateM n newId+ ii <- newId++ let -- ff ind _ _ (Just ' ') = br ind+ br' ind = br (ind `mod` n)+ br'' f = liftRefReader bs >>= br' . f >> return True+ ff (CharKey '\n') = br'' (+1)+ ff (CharKey ' ') = br'' (+1)+ ff (SimpleKey Key'Backspace) = br'' (+(-1))+ ff k = dkh k+ kh = (return (), ff, return (), ii)++ x = maximum [x | txt <- xs, let (x :& _) = fst $ text__ 15 3 txt ]++ render bv is is' = vcat (zipWith3 g [0..] iss xs) # freeze # frame 0.1+ where+ g ind i txt = (+ (if bv == ind then fromVertices [p2 (-0.3, 0), p2 (-0.1,-0.3), p2 (0.3,0.3)] + # lineCap LineCapRound else mempty) # value mempty # translate (r2 (x / 2,0)) # lw 0.15+ <> te # clipped (rect x y) # value mempty+ <> rect x y # (if i `elem` is then fc yellow else id)+ # (if is' == ii then lc yellow . lw focWidth else lc black . lw 0.02)+ # value_ (br ind) kh i+ ) # frame 0.02++ where ((_ :& y), te) = text__ 15 3 txt++ return $ CWidget (liftM ((,) ([kh],[[kh]])) bs) id render++ Notebook' br xs -> do+ let (names, wis) = unzip xs+ n = length names+ iss <- replicateM n newId+ ii <- newId+ ir <- lift $ newRef (0 :: Int)++ let br' :: Int -> Modifier m ()+ br' ind = br ind' >> writeRef ir ind' where ind' = ind `mod` n+ br'' f = readRef ir >>= br' . f >> return True+ ff (SimpleKey Key'Left) = br'' (+(-1))+ ff (SimpleKey Key'Right) = br'' (+ 1)+ ff (AltKey (Key'Char c)) | Just i <- ind c = br'' (const i)+ ff k = dkh k++ ind c | 0 <= i && i < n = Just i+ | otherwise = Nothing+ where i = fromEnum c - fromEnum '1'++ wisv <- mapM (tr sca dkh) wis++ wr <- lift $ onChangeSimple (readRef ir) $ \x -> return $ case wisv !! x of+ CWidget rr hr render -> do+ (es, rrv) <- rr+ return $ (es, UnsafeEqWrap (x, rrv) $ fmap (fmap (fmap hr)) $ render rrv)++ let kh = (return (), ff, return (), ii)++ render (bv, UnsafeEqWrap _ d) is is' =+ vcat+ [ strutY 0.1+ , alignL $ line 0.2+ ||| hcat (intersperse (line 0.1) $ zipWith3 g [0..] iss names)+ ||| line 100+ , strutY 0.2+ , alignL $ d is is'+ ] # freeze+ where+ line dx = fromOffsets [r2 (dx,0)] # strokeLine # translate (r2 (0,-0.5)) # value mempty # lcw++ lcw = if is' == ii then lc yellow . lw focWidth else lc black . lw 0.02++ g ind i txt =+ te # clipped (rect x y) # value mempty+ # fc black+ <> bez # value mempty+ # lcw+ <> (if bv == ind then mempty else line x # translate (r2 (-x/2, 0))) # lcw+ <> bez' # closeLine # strokeLoop # translate (r2 (-x/2,-y/2)) # lw 0+ # (if bv == ind then value mempty else value_ (br' ind) kh i)+ # (if bv /= ind then fc (if i `elem` is then yellow else defcolor) else id)+ where ((x_ :& y), te) = text__ 10 3 txt+ x = x_ + 2+ bez = fromSegments [ bezier3 (r2 (0.7,0)) (r2 (0.3,1)) (r2 (1,1))+ , straight (r2 (x - 2, 0))+ , bezier3 (r2 (0.7,0)) (r2 (0.3,-1)) (r2 (1,-1))+ ] # translate (r2 (-x/2,-y/2))+ bez' = fromSegments [ bezier3 (r2 (0.7,0)) (r2 (0.3,1)) (r2 (1,1))+ , straight (r2 (x - 2, 0))+ , bezier3 (r2 (0.7,0)) (r2 (0.3,-1)) (r2 (1,-1))+ ]++ return $ CWidget (liftM2 (\iv ((ls,ls'),vv) -> ((kh:ls,[kh]:ls'), (iv, vv))) (readRef ir) (join wr)) id render++ Scale mi ma step (sr,rr) -> do+ i <- newId+ mv <- lift $ newRef Nothing++ let ff (SimpleKey Key'Right) = modR $ min ma . (+step)+ ff (SimpleKey Key'Left) = modR $ max mi . (+(-step))+ ff k = dkh k+ kh = (return (), ff, return (), i)+ modR f = do+ v <- liftRefReader sr+ rr $ f v+ return True++ adj x = do+ m <- readRef mv+ case m of+ Just (x_, v) -> rr $ min ma $ max mi $ v + (ma - mi) * (x - x_) / 10+ Nothing -> return ()++ f (Click (MousePos p _), _) = Just' (liftRefReader sr >>= \v -> writeRef mv $ Just (getx p, v), Just f', Just kh, i)+ f (MoveTo _, _) = Just' (return (), Nothing, Nothing, i)+ f _ = mempty++ f' (Release (MousePos p _), _) = adj (getx p) >> writeRef mv Nothing >> return False+ f' (MoveTo (MousePos p _), _) = adj (getx p) >> return True+ f' _ = return True++ getx p = case coords p of (x :& _) -> x++ render r is is' =+ ( circle 0.38 # value f+ # fc (if i `elem` is then yellow else sRGB 0.95 0.95 0.95)+ # lw 0.02 -- (if is' == i then lc yellow . lw focWidth else lc black . lw 0.02)+ # translate (r2 (10 * ((r - mi) / (ma - mi)) - 5, 0))+ <> ( fromVertices [p2 (-5, 0), p2 (5,0)] # lineCap LineCapRound # lw 0.05+ <> roundedRect 11 1 0.5 # lw 0 # fc (if is' == i then yellow else sRGB 0.95 0.95 0.95)+ ) # value mempty+ ) # freeze # frame 0.1++ return $ CWidget (liftM ((,) ([kh],[[kh]])) sr) id render+++--------------------++data UnsafeEqWrap b = forall a . Eq a => UnsafeEqWrap a b+instance Eq (UnsafeEqWrap b) where+ UnsafeEqWrap a _ == UnsafeEqWrap b _ = a == unsafeCoerce b++
+ src/LGtk/Widgets.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+-- | Lens-based Gtk interface+module LGtk.Widgets+ ( module LGtk.Widgets+ , Colour, RGB (..), sRGB, toSRGB+ ) where++import Data.Semigroup+import Data.Colour+import Data.Colour.SRGB+import Diagrams.Prelude (QDiagram, R2, P2)+import Diagrams.Backend.Cairo (B)++---------------------------------------------------------++import Data.LensRef++import LGtk.Key++---------------------------------------------------------++type Receive m a = a -> Modifier m ()++type SendReceive m a = (RefReader m a, Receive m a)++type Widget m = m (WidgetCore m)++-- | Widget descriptions+data WidgetCore m+ = Label (RefReader m String) -- ^ label+ | Button { label_ :: RefReader m String+ , sensitive_ :: RefReader m Bool+ , color_ :: Maybe (RefReader m (Colour Double))+ , action_ :: Receive m ()+ } -- ^ button+ | Checkbox (SendReceive m Bool) -- ^ checkbox+ | Combobox [String] (SendReceive m Int) -- ^ combo box+ | Entry (String -> Bool) (SendReceive m String) -- ^ entry field+ | List ListLayout [Widget m] -- ^ group interfaces into row or column+ | Notebook' (Receive m Int) [(String, Widget m)] -- ^ actual tab index, tabs+ | forall b . Eq b => Cell (RefReader m b) (forall x . (Widget m -> m x) -> b -> m (m x))+ | forall a b . (Eq b, Monoid a, Semigroup a)+ => Canvas+ Int -- width+ Int -- height+ Double -- scale+ ((MouseEvent a, Dia a) -> Modifier m ()) -- mouse event handler+ (KeyboardHandler (Modifier m)) -- keyboard event handler+ (RefReader m b)+ (b -> Dia a)+ | Scale Double Double Double (SendReceive m Double)+++type Dia a = QDiagram B R2 a++data ListLayout+ = Horizontal+ | Vertical+ deriving (Eq)++type ScrollDirection = ListLayout++type KeyboardHandler m = Maybe (ModifiedKey -> m Bool)++data MouseEvent a+ = MoveTo (MousePos a)+ | MouseEnter (MousePos a)+ | MouseLeave (MousePos a)+ | Click (MousePos a)+ | DragTo (MousePos a)+ | Release (MousePos a)+ | ScrollTo ScrollDirection (MousePos a)+ | LostFocus+ | GetFocus+ deriving (Eq)++data MousePos a+ = MousePos P2 a+ deriving (Eq)