diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -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. + diff --git a/lgtk.cabal b/lgtk.cabal --- a/lgtk.cabal +++ b/lgtk.cabal @@ -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: + . + - + . + - + . + - + . + - 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 - - diff --git a/lgtkdemo/Data/Equivalence/Persistent.hs b/lgtkdemo/Data/Equivalence/Persistent.hs new file mode 100644 --- /dev/null +++ b/lgtkdemo/Data/Equivalence/Persistent.hs @@ -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 + + diff --git a/lgtkdemo/LGtk/ADTEditor.hs b/lgtkdemo/LGtk/ADTEditor.hs new file mode 100644 --- /dev/null +++ b/lgtkdemo/LGtk/ADTEditor.hs @@ -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 + + diff --git a/lgtkdemo/LGtk/Demos/IntListEditor.hs b/lgtkdemo/LGtk/Demos/IntListEditor.hs new file mode 100644 --- /dev/null +++ b/lgtkdemo/LGtk/Demos/IntListEditor.hs @@ -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 + ] + + + diff --git a/lgtkdemo/LGtk/Demos/Main.hs b/lgtkdemo/LGtk/Demos/Main.hs new file mode 100644 --- /dev/null +++ b/lgtkdemo/LGtk/Demos/Main.hs @@ -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 "<<>>" 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] + + + diff --git a/lgtkdemo/LGtk/Demos/Maze.hs b/lgtkdemo/LGtk/Demos/Maze.hs new file mode 100644 --- /dev/null +++ b/lgtkdemo/LGtk/Demos/Maze.hs @@ -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) + + diff --git a/lgtkdemo/LGtk/Demos/Maze/Maze.hs b/lgtkdemo/LGtk/Demos/Maze/Maze.hs new file mode 100644 --- /dev/null +++ b/lgtkdemo/LGtk/Demos/Maze/Maze.hs @@ -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 + diff --git a/lgtkdemo/LGtk/Demos/Maze/Types.hs b/lgtkdemo/LGtk/Demos/Maze/Types.hs new file mode 100644 --- /dev/null +++ b/lgtkdemo/LGtk/Demos/Maze/Types.hs @@ -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 + diff --git a/lgtkdemo/LGtk/Demos/MazeGen.hs b/lgtkdemo/LGtk/Demos/MazeGen.hs new file mode 100644 --- /dev/null +++ b/lgtkdemo/LGtk/Demos/MazeGen.hs @@ -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 [] _ = [] + diff --git a/lgtkdemo/LGtk/Demos/TEditor.hs b/lgtkdemo/LGtk/Demos/TEditor.hs new file mode 100644 --- /dev/null +++ b/lgtkdemo/LGtk/Demos/TEditor.hs @@ -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 + ] + ] + + diff --git a/lgtkdemo/LGtk/Demos/Tri.hs b/lgtkdemo/LGtk/Demos/Tri.hs new file mode 100644 --- /dev/null +++ b/lgtkdemo/LGtk/Demos/Tri.hs @@ -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"] + ] + + + + + + diff --git a/lgtkdemo/Main.hs b/lgtkdemo/Main.hs new file mode 100644 --- /dev/null +++ b/lgtkdemo/Main.hs @@ -0,0 +1,5 @@ + +import qualified LGtk.Demos.Main as LGtk ( main ) + +main :: IO () +main = LGtk.main diff --git a/src/Control/Monad/EffRef.hs b/src/Control/Monad/EffRef.hs deleted file mode 100644 --- a/src/Control/Monad/EffRef.hs +++ /dev/null @@ -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) - diff --git a/src/Control/Monad/ExtRef.hs b/src/Control/Monad/ExtRef.hs deleted file mode 100644 --- a/src/Control/Monad/ExtRef.hs +++ /dev/null @@ -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 - -} - 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 - diff --git a/src/Control/Monad/ExtRef/Pure.hs b/src/Control/Monad/ExtRef/Pure.hs deleted file mode 100644 --- a/src/Control/Monad/ExtRef/Pure.hs +++ /dev/null @@ -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 - diff --git a/src/Control/Monad/ExtRef/Test.hs b/src/Control/Monad/ExtRef/Test.hs deleted file mode 100644 --- a/src/Control/Monad/ExtRef/Test.hs +++ /dev/null @@ -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 - diff --git a/src/Control/Monad/Restricted.hs b/src/Control/Monad/Restricted.hs deleted file mode 100644 --- a/src/Control/Monad/Restricted.hs +++ /dev/null @@ -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 - - diff --git a/src/Data/Lens/Common.hs b/src/Data/Lens/Common.hs deleted file mode 100644 --- a/src/Data/Lens/Common.hs +++ /dev/null @@ -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) - diff --git a/src/GUI/Gtk/Structures.hs b/src/GUI/Gtk/Structures.hs deleted file mode 100644 --- a/src/GUI/Gtk/Structures.hs +++ /dev/null @@ -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) diff --git a/src/GUI/Gtk/Structures/IO.hs b/src/GUI/Gtk/Structures/IO.hs deleted file mode 100644 --- a/src/GUI/Gtk/Structures/IO.hs +++ /dev/null @@ -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 - - diff --git a/src/LGtk.hs b/src/LGtk.hs --- a/src/LGtk.hs +++ b/src/LGtk.hs @@ -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, []) + diff --git a/src/LGtk/ADTEditor.hs b/src/LGtk/ADTEditor.hs deleted file mode 100644 --- a/src/LGtk/ADTEditor.hs +++ /dev/null @@ -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 - - diff --git a/src/LGtk/Backend/GLFW.hs b/src/LGtk/Backend/GLFW.hs new file mode 100644 --- /dev/null +++ b/src/LGtk/Backend/GLFW.hs @@ -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 diff --git a/src/LGtk/Backend/Gtk.hs b/src/LGtk/Backend/Gtk.hs new file mode 100644 --- /dev/null +++ b/src/LGtk/Backend/Gtk.hs @@ -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 + + diff --git a/src/LGtk/Demos/IntListEditor.hs b/src/LGtk/Demos/IntListEditor.hs deleted file mode 100644 --- a/src/LGtk/Demos/IntListEditor.hs +++ /dev/null @@ -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] - - - diff --git a/src/LGtk/Demos/Main.hs b/src/LGtk/Demos/Main.hs deleted file mode 100644 --- a/src/LGtk/Demos/Main.hs +++ /dev/null @@ -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 "<<>>" 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) - - diff --git a/src/LGtk/Demos/TEditor.hs b/src/LGtk/Demos/TEditor.hs deleted file mode 100644 --- a/src/LGtk/Demos/TEditor.hs +++ /dev/null @@ -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] - ] - - diff --git a/src/LGtk/Demos/Tri.hs b/src/LGtk/Demos/Tri.hs deleted file mode 100644 --- a/src/LGtk/Demos/Tri.hs +++ /dev/null @@ -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"] - ] - - - - - - diff --git a/src/LGtk/Effects.hs b/src/LGtk/Effects.hs new file mode 100644 --- /dev/null +++ b/src/LGtk/Effects.hs @@ -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) + + diff --git a/src/LGtk/Key.hs b/src/LGtk/Key.hs new file mode 100644 --- /dev/null +++ b/src/LGtk/Key.hs @@ -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 + diff --git a/src/LGtk/Render.hs b/src/LGtk/Render.hs new file mode 100644 --- /dev/null +++ b/src/LGtk/Render.hs @@ -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 + + diff --git a/src/LGtk/Widgets.hs b/src/LGtk/Widgets.hs new file mode 100644 --- /dev/null +++ b/src/LGtk/Widgets.hs @@ -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)