simple-ui (empty) → 0.1.0
raw patch · 31 files changed
+3182/−0 lines, 31 filesdep +basedep +data-default-classdep +exceptionssetup-changed
Dependencies added: base, data-default-class, exceptions, lens, mtl, stm, template-haskell, transformers, vector, vty
Files
- LICENSE +1/−0
- Setup.hs +2/−0
- simple-ui.cabal +64/−0
- src/Simple/Locale/Languages.hs +58/−0
- src/Simple/Locale/Translate.hs +34/−0
- src/Simple/Locale/TranslateClass.hs +31/−0
- src/Simple/Locale/TranslateTH.hs +53/−0
- src/Simple/UI/All.hs +72/−0
- src/Simple/UI/Core/Attribute.hs +109/−0
- src/Simple/UI/Core/Draw.hs +229/−0
- src/Simple/UI/Core/Internal/UIApp.hs +107/−0
- src/Simple/UI/Core/ListenerList.hs +112/−0
- src/Simple/UI/Core/UIApp.hs +188/−0
- src/Simple/UI/Layouts/FillLayout.hs +172/−0
- src/Simple/UI/Layouts/SingleLayout.hs +95/−0
- src/Simple/UI/Utils.hs +32/−0
- src/Simple/UI/Widgets/Container.hs +138/−0
- src/Simple/UI/Widgets/Edit.hs +224/−0
- src/Simple/UI/Widgets/Label.hs +125/−0
- src/Simple/UI/Widgets/Properties/Selected.hs +52/−0
- src/Simple/UI/Widgets/SimpleMenuBar.hs +99/−0
- src/Simple/UI/Widgets/SimpleMenuItem.hs +122/−0
- src/Simple/UI/Widgets/StatusBar.hs +108/−0
- src/Simple/UI/Widgets/Text.hs +80/−0
- src/Simple/UI/Widgets/TextItem.hs +103/−0
- src/Simple/UI/Widgets/TextListView.hs +277/−0
- src/Simple/UI/Widgets/TextView.hs +172/−0
- src/Simple/UI/Widgets/Widget.hs +201/−0
- src/Simple/UI/Widgets/Widget.hs-boot +25/−0
- src/Simple/UI/Widgets/Window.hs +91/−0
- stack.yaml +6/−0
+ LICENSE view
@@ -0,0 +1,1 @@+GPL
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ simple-ui.cabal view
@@ -0,0 +1,64 @@+name: simple-ui+version: 0.1.0+cabal-version: >=1.22+build-type: Simple+author: Piotr Borek <piotrborek@op.pl>+maintainer: Piotr Borek <piotrborek@op.pl>+license: GPL-2+license-file: LICENSE+synopsis: UI library for terminal.+description: UI library for terminal.+category: Graphics++data-files:+ stack.yaml++library+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ default-extensions:+ CPP+ MultiParamTypeClasses+ FlexibleInstances+ TypeFamilies++ build-depends:+ base (>= 4.9 && < 5),+ transformers (>= 0.5 && < 0.6),+ mtl (>= 2.2 && < 2.3),+ exceptions (>= 0.8 && < 0.11),+ vty (>= 5.16 && < 6),+ lens (>= 4.15 && < 4.17),+ vector (>= 0.11 && < 0.13),+ data-default-class (>= 0.1 && < 0.2),+ template-haskell (>= 2.11 && < 2.14),+ stm (>= 2.4 && < 2.5)++ other-modules:+ Simple.UI.All+ Simple.UI.Utils+ Simple.UI.Core.UIApp+ Simple.UI.Core.Draw+ Simple.UI.Core.Attribute+ Simple.UI.Core.ListenerList+ Simple.UI.Core.Internal.UIApp+ Simple.UI.Layouts.FillLayout+ Simple.UI.Layouts.SingleLayout+ Simple.UI.Widgets.Widget+ Simple.UI.Widgets.Properties.Selected+ Simple.UI.Widgets.Container+ Simple.UI.Widgets.Edit+ Simple.UI.Widgets.Label+ Simple.UI.Widgets.TextView+ Simple.UI.Widgets.StatusBar+ Simple.UI.Widgets.Text+ Simple.UI.Widgets.Window+ Simple.UI.Widgets.SimpleMenuBar+ Simple.UI.Widgets.SimpleMenuItem+ Simple.UI.Widgets.TextListView+ Simple.UI.Widgets.TextItem+ Simple.Locale.Languages+ Simple.Locale.Translate+ Simple.Locale.TranslateClass+ Simple.Locale.TranslateTH
+ src/Simple/Locale/Languages.hs view
@@ -0,0 +1,58 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2016 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module Simple.Locale.Languages (+ LANG (..),+ getSystemLanguage+) where++#ifdef WINDOWS+import System.Win32.NLS+#else+import System.Environment+#endif++import System.IO.Unsafe++data LANG = LANG_UNKNOWN+ | LANG_PL+ deriving Show++#ifdef WINDOWS+detectLanguage :: IO LANG+detectLanguage = do+ let lang = getUserDefaultLCID+ case lang of+ 1045 -> return LANG_PL+ _ -> return LANG_UNKNOWN+#else+detectLanguage :: IO LANG+detectLanguage = do+ lang <- getEnv "LANG"+ case lang of+ 'p':'l':'_':'P':'L':_ -> return LANG_PL+ _ -> return LANG_UNKNOWN+#endif++{-# NOINLINE getSystemLanguage #-}+getSystemLanguage :: LANG+getSystemLanguage = unsafePerformIO detectLanguage
+ src/Simple/Locale/Translate.hs view
@@ -0,0 +1,34 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2016 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module Simple.Locale.Translate (+ translate+) where++import Data.Proxy++import qualified Simple.Locale.TranslateClass as C++import Simple.Locale.Languages++translate :: C.Translate a => Proxy a -> String+translate = C.translate getSystemLanguage
+ src/Simple/Locale/TranslateClass.hs view
@@ -0,0 +1,31 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module Simple.Locale.TranslateClass where++import Data.Proxy+import GHC.TypeLits++import Simple.Locale.Languages++class KnownSymbol a => Translate a where+ translate :: LANG -> Proxy a -> String
+ src/Simple/Locale/TranslateTH.hs view
@@ -0,0 +1,53 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module Simple.Locale.TranslateTH (+ tr,+ module Simple.Locale.Translate,+ module Data.Proxy+) where++import Language.Haskell.TH+import Language.Haskell.TH.Quote++import Data.Proxy+import Simple.Locale.Translate++tr :: QuasiQuoter+tr = QuasiQuoter+ { quoteExp = translateTH+ , quotePat = error "quotePat not supported"+ , quoteType = error "quoteType not supported"+ , quoteDec = error "qutoteDec not supported"+ }++translateTH :: String -> Q Exp+translateTH s = return $+ AppE+ (VarE (mkName "Simple.Locale.TranslateTH.translate"))+ (SigE+ (ConE (mkName "Simple.Locale.TranslateTH.Proxy"))+ (AppT+ (ConT (mkName "Simple.Locale.TranslateTH.Proxy"))+ (LitT (StrTyLit s))+ )+ )
+ src/Simple/UI/All.hs view
@@ -0,0 +1,72 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2016 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module Simple.UI.All (+ module Simple.UI.Core.UIApp,+ module Simple.UI.Core.Draw,+ module Simple.UI.Core.Attribute,+ module Simple.UI.Core.ListenerList,+ module Simple.UI.Layouts.FillLayout,+ module Simple.UI.Layouts.SingleLayout,+ module Simple.UI.Utils,+ module Simple.UI.Widgets.Properties.Selected,+ module Simple.UI.Widgets.Widget,+ module Simple.UI.Widgets.Container,+ module Simple.UI.Widgets.Edit,+ module Simple.UI.Widgets.Label,+ module Simple.UI.Widgets.TextListView,+ module Simple.UI.Widgets.TextView,+ module Simple.UI.Widgets.TextItem,+ module Simple.UI.Widgets.StatusBar,+ module Simple.UI.Widgets.Text,+ module Simple.UI.Widgets.Window,+ module Simple.UI.Widgets.SimpleMenuBar,+ module Simple.UI.Widgets.SimpleMenuItem,+ -- reexports+ (.=),+ assign,+ view,+ (^.)+) where++import Control.Lens (assign, view, (.=),+ (^.))+import Simple.UI.Core.Attribute+import Simple.UI.Core.Draw+import Simple.UI.Core.ListenerList+import Simple.UI.Core.UIApp+import Simple.UI.Layouts.FillLayout+import Simple.UI.Layouts.SingleLayout+import Simple.UI.Utils+import Simple.UI.Widgets.Container+import Simple.UI.Widgets.Edit+import Simple.UI.Widgets.Label+import Simple.UI.Widgets.Properties.Selected+import Simple.UI.Widgets.SimpleMenuBar+import Simple.UI.Widgets.SimpleMenuItem+import Simple.UI.Widgets.StatusBar+import Simple.UI.Widgets.Text+import Simple.UI.Widgets.TextItem+import Simple.UI.Widgets.TextListView+import Simple.UI.Widgets.TextView+import Simple.UI.Widgets.Widget+import Simple.UI.Widgets.Window
+ src/Simple/UI/Core/Attribute.hs view
@@ -0,0 +1,109 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-# LANGUAGE BangPatterns #-}++module Simple.UI.Core.Attribute (+ Attribute,+ AttributeList,+ attributeNew,+-- attributeNewOverride,+ get,+ set,+ modify,+ add,+ add',+ readAttr,+ writeAttr,+ modifyAttr,+ connectAttrTo+) where++import Control.Monad+import Control.Monad.IO.Class+import Data.IORef++newtype Attribute a = Attribute (IORef (a, [Attribute a]))++type AttributeList a = Attribute [a]++attributeNew :: MonadIO m => a -> m (Attribute a)+attributeNew !x = liftIO $ Attribute <$> newIORef (x, [])++get :: MonadIO m => s -> (s -> Attribute a) -> m a+get obj getAttr = readAttr $ getAttr obj++set :: MonadIO m => s -> (s -> Attribute a) -> a -> m ()+set obj getAttr = writeAttr $ getAttr obj++modify :: MonadIO m => s -> (s -> Attribute a) -> (a -> a) -> m ()+modify obj getAttr = modifyAttr $ getAttr obj++add :: MonadIO m => s -> (s -> AttributeList a) -> (b -> a) -> b -> m ()+add obj getAttr cast !x = modify obj getAttr $ \xs -> xs ++ [cast x]++add' :: MonadIO m => s -> (s -> AttributeList a) -> a -> m ()+add' obj getAttr !x = add obj getAttr id x++readAttr :: MonadIO m => Attribute a -> m a+readAttr (Attribute attr) = liftIO $ fst <$> readIORef attr++writeAttr :: MonadIO m => Attribute a -> a -> m ()+writeAttr (Attribute attr) !x = liftIO $ do+ (_ , z1) <- readIORef attr+ writeIORef attr (x, z1)+ forM_ z1 $ flip writeAttr x++modifyAttr :: MonadIO m => Attribute a -> (a -> a) -> m ()+modifyAttr attr f = readAttr attr >>= \x -> writeAttr attr (f x)++connectAttrTo :: MonadIO m => Attribute a -> Attribute a -> m ()+connectAttrTo (Attribute from) to = liftIO $ modifyIORef' from $ \(x, z) -> (x, to:z)++{-+data Attribute a = Attribute { _get :: IO a, _set :: a -> IO () }++attributeNew :: MonadIO m => a -> m (Attribute a)+attributeNew !x = do+ ref <- liftIO $ newIORef x+ return Attribute {+ _get = liftIO $ readIORef ref,+ _set = liftIO . writeIORef ref+ }++attributeNewOverride :: IO a -> (a -> IO ()) -> Attribute a+attributeNewOverride getter setter =+ Attribute {+ _get = getter,+ _set = setter+ }++get :: MonadIO m => s -> (s -> Attribute a) -> m a+get obj getAttr = liftIO $ _get (getAttr obj)++set :: MonadIO m => s -> (s -> Attribute a) -> a -> m ()+set obj getAttr !x = liftIO $ _set (getAttr obj) x++modify :: MonadIO m => s -> (s -> Attribute a) -> (a -> a) -> m ()+modify obj getAttr f = liftIO $ do+ x <- _get (getAttr obj)+ _set (getAttr obj) (f x)+-}
+ src/Simple/UI/Core/Draw.hs view
@@ -0,0 +1,229 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module Simple.UI.Core.Draw (+ Drawing,+ DrawingBuilder,+ DrawStyle (..),+ drawingNew,+ drawingToImage,+ drawingToPicture,+ drawingRun,+ drawingGetWidth,+ drawingGetHeight,+ drawingGetSize,+ drawingPutChar,+ drawingPutCharWithAttr,+ drawingPutString,+ drawingPutStringWithAttr,+ drawingSetAttrs,+ drawingClear,+ drawingClearWithAttr,+ drawingSlice,+ drawingSliceNew+) where++import qualified Data.Vector.Mutable as V++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import Data.IORef+import Graphics.Vty++import Simple.UI.Core.Attribute++type DrawingBuilder = ReaderT Drawing IO++data Drawing = Drawing+ { drawingData :: V.IOVector (V.IOVector Image)+ , drawingWidth :: Int+ , drawingHeight :: Int+ , drawingFgColor :: Attribute Color+ , drawingBgColor :: Attribute Color+ , drawingStyle :: Attribute DrawStyle+ }++data DrawStyle = DrawStyleNormal+ | DrawStyleBold+ deriving Eq++drawingStyleNew :: Color -> Color -> DrawStyle -> Attr+drawingStyleNew fg bg style =+ if style == DrawStyleBold+ then defAttr `withForeColor` fg `withBackColor` bg `withStyle` bold+ else defAttr `withForeColor` fg `withBackColor` bg++drawingNew :: MonadIO m => Int -> Int -> m Drawing+drawingNew width height = do+ dta <- liftIO $ V.replicateM height $ V.replicateM width (return $ char defaultStyle ' ')+ fg <- attributeNew white+ bg <- attributeNew black+ style <- attributeNew DrawStyleNormal+ return Drawing+ { drawingData = dta+ , drawingWidth = width+ , drawingHeight = height+ , drawingFgColor = fg+ , drawingBgColor = bg+ , drawingStyle = style+ }+ where+ defaultStyle = drawingStyleNew white black DrawStyleNormal++drawingToImage :: MonadIO m => Drawing -> m Image+drawingToImage drawing = do+ rows <- liftIO $ forM [0 .. height - 1] $ \i -> do+ row <- V.read (drawingData drawing) i+ mergeLine row+ liftIO $ mergeRows rows+ where+ height = V.length $ drawingData drawing++ mergeLine row = do+ let width = V.length row+ image <- newIORef emptyImage+ forM_ [0 .. width - 1] $ \i -> do+ c <- V.read row i+ modifyIORef' image (<|> c)+ readIORef image++ mergeRows images = do+ image <- newIORef emptyImage+ forM_ images $ \i ->+ modifyIORef' image (<-> i)+ readIORef image++drawingToPicture :: MonadIO m => Drawing -> m Picture+drawingToPicture drawing = fmap picForImage (drawingToImage drawing)++--++drawingRun :: MonadIO m => Drawing -> DrawingBuilder a -> m a+drawingRun drawing builder = liftIO $ runReaderT builder drawing++drawingGetWidth :: DrawingBuilder Int+drawingGetWidth = asks drawingWidth++drawingGetHeight :: DrawingBuilder Int+drawingGetHeight = asks drawingHeight++drawingGetSize :: DrawingBuilder (Int, Int)+drawingGetSize = do+ width <- drawingGetWidth+ height <- drawingGetHeight+ return (width, height)++drawingPutChar :: Int -> Int -> Char -> DrawingBuilder ()+drawingPutChar x y c = do+ drawing <- ask+ fg <- get drawing drawingFgColor+ bg <- get drawing drawingBgColor+ style <- get drawing drawingStyle+ drawingPutCharWithAttr fg bg style x y c++drawingPutCharWithAttr :: Color -> Color -> DrawStyle -> Int -> Int -> Char -> DrawingBuilder ()+drawingPutCharWithAttr fg bg style x y c =+ when (x >= 0 && y >= 0) $ do+ width <- drawingGetWidth+ height <- drawingGetHeight+ when (x < width && y < height) $ do+ drawing <- ask+ line <- V.read (drawingData drawing) y+ V.write line x (char attr c)+ where+ attr = drawingStyleNew fg bg style++drawingPutString :: Int -> Int -> String -> DrawingBuilder ()+drawingPutString x y cs = do+ drawing <- ask+ fg <- get drawing drawingFgColor+ bg <- get drawing drawingBgColor+ style <- get drawing drawingStyle+ drawingPutStringWithAttr fg bg style x y cs++drawingPutStringWithAttr :: Color -> Color -> DrawStyle -> Int -> Int -> String -> DrawingBuilder ()+drawingPutStringWithAttr _ _ _ _ _ [] = return ()+drawingPutStringWithAttr fg bg style x y (c:cs) = do+ drawingPutCharWithAttr fg bg style x y c+ drawingPutStringWithAttr fg bg style (x + 1) y cs++drawingSetAttrs :: Color -> Color -> DrawStyle -> DrawingBuilder ()+drawingSetAttrs fg bg style = do+ drawing <- ask+ set drawing drawingFgColor fg+ set drawing drawingBgColor bg+ set drawing drawingStyle style++drawingClear :: DrawingBuilder ()+drawingClear = do+ drawing <- ask+ fg <- get drawing drawingFgColor+ bg <- get drawing drawingBgColor+ style <- get drawing drawingStyle+ drawingClearWithAttr fg bg style++drawingClearWithAttr :: Color -> Color -> DrawStyle -> DrawingBuilder ()+drawingClearWithAttr fg bg style = do+ width <- drawingGetWidth+ height <- drawingGetHeight+ forM_ [0 .. height - 1] $ \y ->+ forM_ [0 .. width - 1] $ \x ->+ drawingPutCharWithAttr fg bg style x y ' '++drawingSlice :: Int -> Int -> Int -> Int -> DrawingBuilder Drawing+drawingSlice x y width height = do+ let x' = if x < 0 then 0 else x+ let y' = if y < 0 then 0 else y++ origWidth <- asks drawingWidth+ origHeight <- asks drawingHeight+ origDrawing <- asks drawingData++ let width' = if x' + width > origWidth then origWidth - x' else width+ let height' = if y' + height > origHeight then origHeight - y' else height++ h <- liftIO $ newIORef y'+ drawing <- liftIO $ V.replicateM height' $ do+ h' <- increment h+ line <- V.read origDrawing h'+ return (V.slice x' width' line)++ fg <- attributeNew white+ bg <- attributeNew black+ style <- attributeNew DrawStyleNormal+ return Drawing+ { drawingData = drawing+ , drawingWidth = width'+ , drawingHeight = height'+ , drawingFgColor = fg+ , drawingBgColor = bg+ , drawingStyle = style+ }+ where+ increment ref = do+ i <- readIORef ref+ modifyIORef' ref (+1)+ return i++drawingSliceNew :: MonadIO m => Drawing -> Int -> Int -> Int -> Int -> m Drawing+drawingSliceNew drawing x y width height = drawingRun drawing $ drawingSlice x y width height
+ src/Simple/UI/Core/Internal/UIApp.hs view
@@ -0,0 +1,107 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2016 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}++module Simple.UI.Core.Internal.UIApp where++import qualified Graphics.Vty as Vty++import Control.Concurrent.STM+import Control.Lens+import Control.Monad.IO.Class+import Control.Monad.State.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict hiding (get, put)++import Simple.UI.Core.Draw++import {-# SOURCE #-} Simple.UI.Widgets.Widget+++type UIApp u = ReaderT (AppConfig u) (StateT AppState IO)++type UIApp' = UIApp ()++data UIAppEvent = UIAppEventResize Int Int+ | UIAppEventKeyPressed Vty.Key [Vty.Modifier]+ | UIAppEventAction (UIApp' ())+ | UIAppEventQuit++type UIAppTasks = TChan UIAppEvent++data AppConfig u = AppConfig+ { _appVty :: Vty.Vty+ , _appTasks :: UIAppTasks+ , _appUserData :: u+ }++data AppState = AppState+ { _appIdCounter :: Integer+ , _appWidth :: Int+ , _appHeight :: Int+ , _appDrawing :: Drawing+ , _appRoot :: Maybe Widget+ }++makeLenses ''AppConfig+makeLenses ''AppState++instance Eq UIAppEvent where+ UIAppEventQuit == UIAppEventQuit = True+ _ == _ = False++uniqueIdNew :: UIApp u Integer+uniqueIdNew = appIdCounter <+= 1++_runUIApp :: MonadIO m => AppConfig u -> AppState -> UIApp u a -> m (a, AppState)+_runUIApp initConfig initState app = liftIO $ runStateT (runReaderT app initConfig) initState++liftUIApp' :: UIApp' a -> UIApp u a+liftUIApp' app = do+ s <- get+ r <- ask+ (x, s') <- _runUIApp (newConf r) s app+ put s'+ return x+ where+ newConf :: AppConfig u -> AppConfig ()+ newConf conf = AppConfig+ { _appVty = _appVty conf+ , _appTasks = _appTasks conf+ , _appUserData = undefined+ }++liftUIApp :: u -> UIApp u a -> UIApp' a+liftUIApp userData app = do+ s <- get+ r <- ask++ let appConf = AppConfig+ { _appVty = _appVty r+ , _appTasks = _appTasks r+ , _appUserData = userData+ }++ (x, s') <- _runUIApp appConf s app+ put s'+ return x
+ src/Simple/UI/Core/ListenerList.hs view
@@ -0,0 +1,112 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module Simple.UI.Core.ListenerList (+ ListenerID,+ ListenerList,+ on,+ on_,+ fire,+ listenerNew,+) where++import Control.Monad+import Control.Monad.IO.Class+import Data.IORef++import Simple.UI.Core.Internal.UIApp++type ListenerID = Integer+type ListenerList a = IORef [(ListenerID, a)]++class Fire a b where+ fire :: w -> (w -> ListenerList a) -> b -> UIApp u ()++instance Fire (UIApp' ()) () where+ fire = fire0++instance Fire (a -> UIApp' ()) a where+ fire = fire1++instance Fire (a -> b -> UIApp' ()) (a, b) where+ fire = fire2++instance Fire (a -> b -> c -> UIApp' ()) (a, b, c) where+ fire = fire3++instance Fire (a -> b -> c -> d -> UIApp' ()) (a, b, c, d) where+ fire = fire4++on :: w -> (w -> ListenerList a) -> a -> UIApp u ListenerID+on widget listeners = listenerAdd (listeners widget)++on_ :: w -> (w -> ListenerList a) -> a -> UIApp u ()+on_ widget listeners f = void $ on widget listeners f++listenerNew :: MonadIO m => m (ListenerList a)+listenerNew = liftIO $ newIORef []++listenerAdd :: ListenerList a -> a -> UIApp u ListenerID+listenerAdd listeners f = do+ listenerID <- uniqueIdNew+ liftIO $ modifyIORef' listeners $ \xs -> (listenerID, f):xs+ return listenerID++listenerFire0 :: ListenerList (UIApp' ()) -> () -> UIApp u ()+listenerFire0 listeners _ = do+ list <- liftIO $ readIORef listeners+ liftUIApp' $ forM_ list snd++fire0 :: w -> (w -> ListenerList (UIApp' ())) -> () -> UIApp u ()+fire0 widget listeners = listenerFire0 (listeners widget)++listenerFire1 :: ListenerList (a -> UIApp' ()) -> a -> UIApp u ()+listenerFire1 listeners a0 = do+ list <- liftIO $ readIORef listeners+ liftUIApp' $ forM_ list $ \(_, f) -> f a0++fire1 :: w -> (w -> ListenerList (a -> UIApp' ())) -> a -> UIApp u ()+fire1 widget listeners = listenerFire1 (listeners widget)++listenerFire2 :: ListenerList (a -> b -> UIApp' ()) -> (a, b) -> UIApp u ()+listenerFire2 listeners (a0, a1) = do+ list <- liftIO $ readIORef listeners+ liftUIApp' $ forM_ list $ \(_, f) -> f a0 a1++fire2 :: w -> (w -> ListenerList (a -> b -> UIApp' ())) -> (a, b) -> UIApp u ()+fire2 widget listeners = listenerFire2 (listeners widget)++listenerFire3 :: ListenerList (a -> b -> c -> UIApp' ()) -> (a, b, c) -> UIApp u ()+listenerFire3 listeners (a0, a1, a2) = do+ list <- liftIO $ readIORef listeners+ liftUIApp' $ forM_ list $ \(_, f) -> f a0 a1 a2++fire3 :: w -> (w -> ListenerList (a -> b -> c -> UIApp' ())) -> (a, b, c) -> UIApp u ()+fire3 widget listeners = listenerFire3 (listeners widget)++listenerFire4 :: ListenerList (a -> b -> c -> d -> UIApp' ()) -> (a, b, c, d) -> UIApp u ()+listenerFire4 listeners (a0, a1, a2, a3) = do+ list <- liftIO $ readIORef listeners+ liftUIApp' $ forM_ list $ \(_, f) -> f a0 a1 a2 a3++fire4 :: w -> (w -> ListenerList (a -> b -> c -> d -> UIApp' ())) -> (a, b, c, d) -> UIApp u ()+fire4 widget listeners = listenerFire4 (listeners widget)
+ src/Simple/UI/Core/UIApp.hs view
@@ -0,0 +1,188 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2016 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ViewPatterns #-}++module Simple.UI.Core.UIApp (+ runUIApp,+ runMainLoop,+ runDialogLoop,+ mainLoopQuit,+ mainSchedule,+ mainScheduleAfter,+ mainScheduleRepeat,+ -- reexports+ UIApp,+ UIApp',+ UIAppEvent (..),+ liftUIApp,+ liftUIApp',+ appUserData,+ uniqueIdNew+) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Lens+import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.Maybe+import GHC.Stack+import qualified Graphics.Vty as Vty++import Simple.UI.Core.Draw+import Simple.UI.Core.Internal.UIApp+import Simple.UI.Core.ListenerList+import Simple.UI.Widgets.Widget+import Simple.UI.Widgets.Window++-- core functions++newtype UIAppException = UIAppWindowIsNotTopLevelException CallStack++instance Show UIAppException where+ show (UIAppWindowIsNotTopLevelException stack) = "UIAppWindowIsNotTopLevelException\n\n" ++ prettyCallStack stack++instance Exception UIAppException++runUIApp :: u -> UIApp u () -> IO ()+runUIApp userData app = do+ appConfig <- initAppConfig+ appState <- initAppState++ void $ _runUIApp appConfig appState app `finally` Vty.shutdown (appConfig ^. appVty)+ where+ initAppConfig = do+ c <- liftIO Vty.standardIOConfig+ v <- liftIO $ Vty.mkVty c+ tasks <- liftIO $ atomically newTChan+ liftIO $ Vty.hideCursor (Vty.outputIface v)+ return AppConfig+ { _appVty = v+ , _appTasks = tasks+ , _appUserData = userData+ }++ initAppState = do+ d <- drawingNew 0 0+ return AppState+ { _appIdCounter = 0+ , _appWidth = 0+ , _appHeight = 0+ , _appDrawing = d+ , _appRoot = Nothing+ }++runMainLoop :: (HasCallStack, WindowClass w) => w a -> UIApp u ()+runMainLoop (castToWindow -> root) = do+ when (windowType root /= WindowTypeTopLevel) $ throwM $ UIAppWindowIsNotTopLevelException ?callStack++ appRoot .= (Just $ castToWidget root)++ vty <- view appVty+ tasks <- view appTasks++ (width, height) <- Vty.displayBounds (Vty.outputIface vty)+ mainResize width height+ mainDraw++ mainEventThreadRun tasks vty+ runDialogLoop root++mainEventThreadRun :: MonadIO m => UIAppTasks -> Vty.Vty -> m ()+mainEventThreadRun tasks vty = void $ liftIO $ forkIO $ forever $ do+ event <- Vty.nextEvent vty+ case event of+ Vty.EvKey key modifiers -> atomically $ writeTChan tasks $ UIAppEventKeyPressed key modifiers+ Vty.EvResize width height -> atomically $ writeTChan tasks $ UIAppEventResize width height+ _ -> return ()++mainDraw :: UIApp u ()+mainDraw = do+ root <- fromJust <$> use appRoot+ vty <- view appVty++ drawing <- use appDrawing+ (width, height) <- drawingRun drawing drawingGetSize++ fire root draw (drawing, width, height)++ pic <- drawingToPicture drawing+ liftIO $ Vty.update vty pic++mainResize :: Int -> Int -> UIApp u ()+mainResize width height = do+ d <- drawingNew width height+ appWidth .= width+ appHeight .= height+ appDrawing .= d++runDialogLoop :: WidgetClass w => w -> UIApp u ()+runDialogLoop (castToWidget -> widget) = do+ vty <- view appVty+ tasks <- view appTasks+ dialogLoop vty tasks+ where+ dialogLoop vty tasks = do+ event <- liftIO . atomically $ readTChan tasks++ case event of+ UIAppEventResize width height -> mainResize width height+ UIAppEventKeyPressed key modifiers -> fire widget keyPressed (key, modifiers)+ UIAppEventAction action -> liftUIApp' action+ UIAppEventQuit -> return ()++ mainDraw++ if event == UIAppEventQuit+ then return ()+ else dialogLoop vty tasks++mainLoopQuit :: UIApp u ()+mainLoopQuit = do+ tasks <- view appTasks+ liftIO . atomically $ writeTChan tasks UIAppEventQuit++mainSchedule :: UIApp' () -> UIApp u ()+mainSchedule action = do+ tasks <- view appTasks+ mainSchedule' tasks action++mainSchedule' :: MonadIO m => UIAppTasks -> UIApp' () -> m ()+mainSchedule' tasks action = liftIO $+ atomically $ writeTChan tasks $ UIAppEventAction action++mainScheduleAfter :: Int -> UIApp' () -> UIApp u ()+mainScheduleAfter timeInMillis action = do+ tasks <- view appTasks+ void $ liftIO $ forkIO $ do+ threadDelay (timeInMillis * 1000)+ mainSchedule' tasks action++mainScheduleRepeat :: Int -> UIApp' () -> UIApp u ()+mainScheduleRepeat timeInMillis action = do+ tasks <- view appTasks+ void $ liftIO $ forkIO $ forever $ do+ mainSchedule' tasks action+ threadDelay (timeInMillis * 1000)
+ src/Simple/UI/Layouts/FillLayout.hs view
@@ -0,0 +1,172 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module Simple.UI.Layouts.FillLayout (+ FillLayout (..),+ FillLayoutData (..),+ fillLayoutVerticalNew,+ fillLayoutHorizontalNew,+ def+) where++import Control.Monad+import Data.Default.Class+import Data.Maybe++import Simple.UI.Core.Attribute+import Simple.UI.Core.Draw+import Simple.UI.Core.Internal.UIApp+import Simple.UI.Core.ListenerList+import Simple.UI.Widgets.Container+import Simple.UI.Widgets.Widget++data FillLayout = FillLayoutHorizontal+ | FillLayoutVertical+ deriving (Eq)++data FillLayoutData = FillLayoutData+ { fillLayoutHExpand :: Bool+ , fillLayoutVExpand :: Bool+ }++instance LayoutClass FillLayout where+ type LayoutData FillLayout = FillLayoutData++ layoutDraw container drawing width height = do+ _layout <- get container layout+ _widgets <- get container widgets+ fillLayoutDraw _layout _widgets drawing width height++ layoutComputeSize container = do+ _widgets <- get container widgets+ if null _widgets+ then+ return (0, 0)+ else do+ _layout <- get container layout+ sizes <- forM _widgets $ \(widget, _) -> do+ v <- get widget visible+ if v then computeSize widget else return (0, 0)+ fillLayoutComputeSize _layout sizes++instance Default FillLayoutData where+ def = FillLayoutData+ { fillLayoutHExpand = True+ , fillLayoutVExpand = True+ }++fillLayoutComputeSize :: FillLayout -> [(Int, Int)] -> UIApp u (Int, Int)+fillLayoutComputeSize FillLayoutVertical sizes =+ return (maximum $ fmap fst sizes, sum $ fmap snd sizes)++fillLayoutComputeSize FillLayoutHorizontal sizes =+ return (sum $ fmap fst sizes, maximum $ fmap snd sizes)++fillLayoutDraw :: FillLayout -> [(Widget, FillLayoutData)] -> Drawing -> Int -> Int -> UIApp u ()+fillLayoutDraw FillLayoutVertical _widgets drawing width height = do+ filteredWidgets <- flip filterM _widgets $ \(widget, _) ->+ get widget visible++ heights <- forM filteredWidgets $ \(widget, layoutData) ->+ if fillLayoutVExpand layoutData+ then return Nothing+ else Just . snd <$> computeSize widget++ let sumHeight = sum $ catMaybes heights+ let deltaH = if height - sumHeight < 0 then 0 else height - sumHeight+ let countEW = countExpandedWidgets filteredWidgets+ let expandedH = if countEW == 0 then 0 else deltaH `div` countEW+ let restH = if countEW == 0 then deltaH else deltaH `mod` countEW++ drawWidgets (fmap fst filteredWidgets) heights expandedH restH 0+ where+ drawWidgets [] _ _ _ _ = return ()+ drawWidgets _ [] _ _ _ = return ()+ drawWidgets (_widget:ws) (maybeHeight:mhs) expandedH restH y =+ case maybeHeight of+ Nothing -> do+ let h = expandedH + nat restH+ layoutDrawWidget _widget drawing 0 y width h+ drawWidgets ws mhs expandedH (dec restH) (y + h)++ Just wHeight -> do+ layoutDrawWidget _widget drawing 0 y width wHeight+ drawWidgets ws mhs expandedH restH (y + wHeight)++ countExpandedWidgets filteredWidgets = sum $+ flip fmap filteredWidgets $ \(_, layoutData) ->+ if fillLayoutVExpand layoutData+ then 1+ else 0++fillLayoutDraw FillLayoutHorizontal _widgets drawing width height = do+ filteredWidgets <- flip filterM _widgets $ \(widget, _) ->+ get widget visible++ widths <- forM filteredWidgets $ \(widget, layoutData) ->+ if fillLayoutHExpand layoutData+ then return Nothing+ else Just . fst <$> computeSize widget++ let sumWidth = sum $ catMaybes widths+ let deltaW = if width - sumWidth < 0 then 0 else width - sumWidth+ let countEW = countExpandedWidgets filteredWidgets+ let expandedW = if countEW == 0 then 0 else deltaW `div` countEW+ let restH = if countEW == 0 then deltaW else deltaW `mod` countEW++ drawWidgets (fmap fst filteredWidgets) widths expandedW restH 0+ where+ drawWidgets [] _ _ _ _ = return ()+ drawWidgets _ [] _ _ _ = return ()+ drawWidgets (_widget:ws) (maybeWidth:mws) expandedW restW x =+ case maybeWidth of+ Nothing -> do+ let w = expandedW + nat restW+ layoutDrawWidget _widget drawing x 0 w height+ drawWidgets ws mws expandedW (dec restW) (x + w)++ Just wWidth -> do+ layoutDrawWidget _widget drawing x 0 wWidth height+ drawWidgets ws mws expandedW restW (x + wWidth)++ countExpandedWidgets filteredWidgets= sum $+ flip fmap filteredWidgets $ \(_, layoutData) ->+ if fillLayoutHExpand layoutData+ then 1+ else 0++layoutDrawWidget :: Widget -> Drawing -> Int -> Int -> Int -> Int -> UIApp u ()+layoutDrawWidget widget drawing x y width height = do+ d <- drawingSliceNew drawing x y width height+ fire widget draw (d, width, height)++fillLayoutVerticalNew :: UIApp u FillLayout+fillLayoutVerticalNew = return FillLayoutVertical++fillLayoutHorizontalNew :: UIApp u FillLayout+fillLayoutHorizontalNew = return FillLayoutHorizontal++dec :: Int -> Int+dec x = if x < 0 then x else x - 1++nat :: Int -> Int+nat x = if x > 0 then 1 else 0
+ src/Simple/UI/Layouts/SingleLayout.hs view
@@ -0,0 +1,95 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-#LANGUAGE ViewPatterns #-}++module Simple.UI.Layouts.SingleLayout (+ SingleLayout (..),+ SingleLayoutData (..),+ SingleLayoutClass,+ singleLayoutNew,+ layoutIndex,+ def+) where++import Control.Lens (element, (^?))+import Control.Monad (forM_)+import Data.Default.Class++import Simple.UI.Core.Internal.UIApp+import Simple.UI.Core.Attribute+import Simple.UI.Core.ListenerList+import Simple.UI.Widgets.Container+import Simple.UI.Widgets.Widget++newtype SingleLayout = SingleLayout+ { _singleLayoutIndex :: Attribute Int+ }++data SingleLayoutData = SingleLayoutData++class LayoutClass w => SingleLayoutClass w where+ layoutIndex :: w -> Attribute Int++instance LayoutClass SingleLayout where+ type LayoutData SingleLayout = SingleLayoutData++ layoutDraw (castToContainer -> container) drawing width height = do+ _widgets <- get container widgets+ forM_ _widgets $ \(widget, _) -> set widget visible False++ maybeWidget <- singleLayoutWidget container+ case maybeWidget of+ Just widget -> do+ set widget visible True+ fire widget draw (drawing, width, height)+ Nothing ->+ return ()++ layoutComputeSize (castToContainer -> container) = do+ maybeWidget <- singleLayoutWidget container+ case maybeWidget of+ Just widget -> computeSize widget+ Nothing -> return (1, 1)++instance SingleLayoutClass SingleLayout where+ layoutIndex = _singleLayoutIndex++instance Default SingleLayoutData where+ def = SingleLayoutData++singleLayoutNew :: UIApp u SingleLayout+singleLayoutNew = do+ index <- attributeNew 0+ return SingleLayout+ { _singleLayoutIndex = index+ }++singleLayoutWidget :: Container SingleLayout -> UIApp u (Maybe Widget)+singleLayoutWidget container = do+ _widgets <- get container widgets+ if null _widgets+ then+ return Nothing+ else do+ _layout <- get container layout+ index <- readAttr $ layoutIndex _layout+ return $ fst <$> _widgets ^? element index
+ src/Simple/UI/Utils.hs view
@@ -0,0 +1,32 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2014 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module Simple.UI.Utils (+ removeAt,+ insertAt+) where++removeAt :: Int -> [a] -> [a]+removeAt index list = take index list ++ drop (succ index) list++insertAt :: Int -> [a] -> a -> [a]+insertAt index list c = take index list ++ (c : drop index list)
+ src/Simple/UI/Widgets/Container.hs view
@@ -0,0 +1,138 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-#LANGUAGE TemplateHaskell #-}++module Simple.UI.Widgets.Container (+ ContainerClass,+ Container,+ castToContainer,+ containerNew,+ widgets,+ layout,+ addTo,+ -- layout+ LayoutClass,+ LayoutData,+ EmptyLayout (..),+ EmptyLayoutData (..),+ layoutDraw,+ layoutComputeSize+) where++import qualified Control.Arrow as Arrow+import Control.Lens ((.=), makeLensesFor)+import Control.Monad+import Control.Monad.IO.Class+import Data.Default.Class++import Simple.UI.Core.Internal.UIApp++import Simple.UI.Core.Attribute+import Simple.UI.Core.Draw+import Simple.UI.Core.ListenerList+import Simple.UI.Widgets.Widget++data EmptyLayout = EmptyLayout+data EmptyLayoutData = EmptyLayoutData++data Container a = Container+ { _containerParent :: Widget+ , _containerWidgets :: AttributeList (Widget, LayoutData a)+ , _containerLayout :: Attribute a+ }++class LayoutClass w where+ type LayoutData w+ layoutDraw :: ContainerClass c => c w -> Drawing -> Int -> Int -> UIApp u ()+ layoutComputeSize :: ContainerClass c => c w -> UIApp u (Int, Int)++class ContainerClass w where+ castToContainer :: w a -> Container a++ widgets :: w a -> AttributeList (Widget, LayoutData a)+ widgets = _containerWidgets . castToContainer++ layout :: w a -> Attribute a+ layout = _containerLayout . castToContainer++ addTo :: (WidgetClass u, MonadIO m) => w a -> u -> LayoutData a -> m ()+ addTo c w d = add c widgets (Arrow.first castToWidget) (w, d)++makeLensesFor [("_containerParent", "containerParent")] ''Container++instance LayoutClass EmptyLayout where+ type LayoutData EmptyLayout = EmptyLayoutData++ layoutDraw _ _ _ _ = return ()++ layoutComputeSize _ = return (1, 1)++instance Default EmptyLayoutData where+ def = EmptyLayoutData++instance ContainerClass Container where+ castToContainer = id++instance WidgetClass (Container a) where+ castToWidget = _containerParent++ overrideWidget = overrideWidgetHelper containerParent++containerNew :: LayoutClass a => a -> UIApp u (Container a)+containerNew _layout = do+ container <- containerNewOverride _layout++ on_ container draw $ \drawing width height -> do+ fg <- get container colorForeground+ bg <- get container colorBackground+ drawingRun drawing $ do+ drawingSetAttrs fg bg DrawStyleNormal+ drawingClear+ layoutDraw container drawing width height++ on_ container keyPressed $ \key modifiers -> do+ _widgets <- get container widgets+ forM_ _widgets $ \(widget, _) -> do+ en <- get widget enabled+ v <- get widget visible+ when (en && v) $ fire widget keyPressed (key, modifiers)++ return container++containerNewOverride :: LayoutClass a => a -> UIApp u (Container a)+containerNewOverride _layout = override <$> containerNewDefault _layout+ where+ override container = overrideWidget container $ do+ virtualWidgetName .= "container"+ virtualWidgetComputeSize .= layoutComputeSize container++containerNewDefault :: LayoutClass a => a -> UIApp u (Container a)+containerNewDefault _layout = do+ parent <- widgetNew+ _widgets <- attributeNew []+ layoutAttr <- attributeNew _layout++ return Container+ { _containerParent = parent+ , _containerWidgets = _widgets+ , _containerLayout = layoutAttr+ }
+ src/Simple/UI/Widgets/Edit.hs view
@@ -0,0 +1,224 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2018 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}++module Simple.UI.Widgets.Edit (+ Edit,+ EditClass,+ castToEdit,+ editNew,+ text+) where++import Control.Lens (makeLensesFor, (.=))+import Control.Monad+import qualified Graphics.Vty as Vty++import Simple.UI.Core.Attribute+import Simple.UI.Core.Draw+import Simple.UI.Core.Internal.UIApp+import Simple.UI.Core.ListenerList+import Simple.UI.Utils+import Simple.UI.Widgets.Text+import Simple.UI.Widgets.Widget++data Edit = Edit+ { _editParent :: Text+ , _editCursorPos :: Attribute Int+ , _editXOffset :: Attribute Int+ , _editWidth :: Attribute Int+ }++makeLensesFor [("_editParent", "editParent")] ''Edit++class TextClass w => EditClass w where+ castToEdit :: w -> Edit++instance EditClass Edit where+ castToEdit = id++instance TextClass Edit where+ castToText = _editParent++instance WidgetClass Edit where+ castToWidget = castToWidget . _editParent++ overrideWidget = overrideWidgetHelper editParent++editNew :: Maybe String -> UIApp u Edit+editNew s = do+ edit <- editNewOverride s++ on_ edit draw $ editDraw edit+ on_ edit keyPressed $ \key _ ->+ case key of+ Vty.KChar c -> do+ pos <- get edit _editCursorPos+ offset <- get edit _editXOffset+ modify edit text $ \case+ Nothing -> Just [c]+ Just x -> Just $ insertAt (pos + offset) x c+ cursorGoRight edit++ Vty.KBS -> do+ pos <- get edit _editCursorPos+ offset <- get edit _editXOffset+ modify edit text $ \case+ Nothing -> Nothing+ Just x -> do+ let x' = removeAt (pos + offset - 1) x+ if null x' then Nothing else Just x'+ cursorGoLeft edit++ Vty.KDel -> do+ pos <- get edit _editCursorPos+ offset <- get edit _editXOffset+ modify edit text $ \case+ Nothing -> Nothing+ Just x -> do+ let x' = removeAt (pos + offset) x+ if null x' then Nothing else Just x'++ Vty.KHome -> do+ modify edit _editCursorPos $ const 0+ modify edit _editXOffset $ const 0++ Vty.KEnd -> do+ _text <- get edit text+ forM_ _text $ \x -> do+ width <- pred <$> get edit _editWidth+ if length x > width+ then do+ modify edit _editCursorPos $ const width+ modify edit _editXOffset $ const (length x - width)+ else do+ modify edit _editCursorPos $ const (length x)+ modify edit _editXOffset $ const 0++ Vty.KLeft ->+ cursorGoLeft edit++ Vty.KRight ->+ cursorGoRight edit++ _ ->+ return ()++ return edit+ where+ cursorGoRight edit = do+ _text <- get edit text+ forM_ _text $ \x -> do+ width <- pred <$> get edit _editWidth+ pos <- get edit _editCursorPos+ offset <- get edit _editXOffset++ let (newPos, newOffset) =+ if pos + 1 > width+ then+ if pos + offset + 1 > length x+ then+ (pos, offset)+ else+ (pos, offset + 1)+ else+ (pos + 1, offset)++ set edit _editCursorPos newPos+ set edit _editXOffset newOffset++ cursorGoLeft edit = do+ _text <- get edit text+ forM_ _text $ \_ -> do+ pos <- get edit _editCursorPos+ offset <- get edit _editXOffset++ let (newPos, newOffset) =+ if pos - 1 < 0+ then+ if offset > 0+ then+ (0, offset - 1)+ else+ (0, 0)+ else+ (pos - 1, offset)++ set edit _editCursorPos newPos+ set edit _editXOffset newOffset++editNewOverride :: Maybe String -> UIApp u Edit+editNewOverride s = override <$> editNewDefault s+ where+ editComputeSize edit = do+ maybeText <- get edit text+ case maybeText of+ Nothing -> return (1, 1)+ Just _text -> do+ let width = if length _text < 2 then 2 else length _text+ return (width ,1)++ override edit = overrideWidget edit $ do+ virtualWidgetName .= "edit"+ virtualWidgetComputeSize .= editComputeSize edit++editNewDefault :: Maybe String -> UIApp u Edit+editNewDefault s = do+ parent <- textNew s+ pos <- attributeNew $ length s+ offset <- attributeNew 0+ width <- attributeNew 1++ return Edit+ { _editParent = parent+ , _editCursorPos = pos+ , _editXOffset = offset+ , _editWidth = width+ }++editDraw :: Edit -> Drawing -> Int -> Int -> UIApp u ()+editDraw edit drawing width _ = do+ set edit _editWidth width++ maybeText <- get edit text++ fg <- get edit colorForeground+ bg <- get edit colorBackground+ style <- get edit colorStyle++ drawingRun drawing $ do+ drawingSetAttrs fg bg style+ drawingClear+ case maybeText of+ Just _text -> do+ pos <- get edit _editCursorPos+ offset <- get edit _editXOffset++ let s = drop offset _text+ forM_ (zip (s ++ " ") [0..]) $ \(c, i) ->+ if pos == i+ then drawingPutCharWithAttr bg fg style i 0 c+ else drawingPutChar i 0 c++ Nothing ->+ drawingPutCharWithAttr bg fg style 0 0 ' '
+ src/Simple/UI/Widgets/Label.hs view
@@ -0,0 +1,125 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-# LANGUAGE TemplateHaskell #-}++module Simple.UI.Widgets.Label (+ Label,+ LabelClass,+ castToLabel,+ labelNew,+ text,+ align+) where++import Control.Lens (makeLensesFor, (.=))+import Control.Monad++import Simple.UI.Core.Internal.UIApp++import Simple.UI.Core.Attribute+import Simple.UI.Core.Draw+import Simple.UI.Core.ListenerList+import Simple.UI.Widgets.Text+import Simple.UI.Widgets.Widget++newtype Label = Label+ { _labelParent :: Text+ }++makeLensesFor [("_labelParent", "labelParent")] ''Label++class TextClass w => LabelClass w where+ castToLabel :: w -> Label++instance LabelClass Label where+ castToLabel = id++instance TextClass Label where+ castToText = _labelParent++instance WidgetClass Label where+ castToWidget = castToWidget . _labelParent++ overrideWidget = overrideWidgetHelper labelParent++labelNew :: Maybe String -> UIApp u Label+labelNew s = do+ label <- labelNewOverride s++ _ <- on label draw $ labelDraw label++ return label++labelNewOverride :: Maybe String -> UIApp u Label+labelNewOverride s = override <$> labelNewDefault s+ where+ labelComputeSize label = do+ maybeText <- get label text++ case maybeText of+ Nothing -> return (1, 1)+ Just _text -> do+ let ls = lines _text+ let ws = map length ls++ let w = maximum ws+ let l = length ls++ return ( if w == 0 then 1 else w+ , if l == 0 then 1 else l+ )++ override label = overrideWidget label $ do+ virtualWidgetName .= "label"+ virtualWidgetComputeSize .= labelComputeSize label++labelNewDefault :: Maybe String -> UIApp u Label+labelNewDefault s = do+ parent <- textNew s++ return Label+ { _labelParent = parent+ }++labelDraw :: Label -> Drawing -> Int -> Int -> UIApp u ()+labelDraw label drawing width height = do+ maybeText <- get label text++ fg <- get label colorForeground+ bg <- get label colorBackground+ style <- get label colorStyle++ drawingRun drawing $ do+ drawingSetAttrs fg bg style+ drawingClear++ forM_ maybeText $ \_text ->+ drawingRun drawing $ do+ let ls = lines _text+ let y = (height - length ls) `div` 2++ _align <- get label align+ forM_ (zip ls [0..]) $ \(l, i) ->+ case _align of+ TextAlignLeft -> drawingPutString 0 (y + i) l+ TextAlignRight -> drawingPutString (width - length l) (y + i) l+ TextAlignCenter -> drawingPutString ((width - length l) `div` 2) (y + i) l
+ src/Simple/UI/Widgets/Properties/Selected.hs view
@@ -0,0 +1,52 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2018 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module Simple.UI.Widgets.Properties.Selected (+ HasSelected,+ selected,+ selectedGetColors+) where++import qualified Graphics.Vty as Vty++import Simple.UI.Core.Attribute+import Simple.UI.Core.Draw+import Simple.UI.Core.Internal.UIApp+import Simple.UI.Widgets.Widget++class WidgetClass w => HasSelected w where+ selected :: w -> Attribute Bool++ selectedGetColors :: w -> UIApp u (Vty.Color, Vty.Color, DrawStyle)+ selectedGetColors widget = do+ sel <- get widget selected+ if sel+ then do+ fg <- get widget colorForegroundSelected+ bg <- get widget colorBackgroundSelected+ style <- get widget colorStyleSelected+ return (fg, bg, style)+ else do+ fg <- get widget colorForeground+ bg <- get widget colorBackground+ style <- get widget colorStyle+ return (fg, bg, style)
+ src/Simple/UI/Widgets/SimpleMenuBar.hs view
@@ -0,0 +1,99 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}++module Simple.UI.Widgets.SimpleMenuBar (+ SimpleMenuBar,+ SimpleMenuBarClass,+ castToSimpleMenuBar,+ simpleMenuBarNew,+ menuBarItemAdd+) where++import Control.Lens (makeLensesFor, (.=))+import Control.Monad+import qualified Graphics.Vty as Vty++import Simple.UI.Core.Attribute+import Simple.UI.Core.ListenerList+import Simple.UI.Core.UIApp+import Simple.UI.Layouts.FillLayout+import Simple.UI.Widgets.Container+import Simple.UI.Widgets.Properties.Selected+import Simple.UI.Widgets.SimpleMenuItem+import Simple.UI.Widgets.Widget++data SimpleMenuBar = SimpleMenuBar+ { _simpleMenuBarParent :: Widget+ , _simpleMenuBarContainer :: Container FillLayout+ , _simpleMenuBarItems :: AttributeList SimpleMenuItem+ }++makeLensesFor [("_simpleMenuBarParent", "simpleMenuBarParent")] ''SimpleMenuBar++class WidgetClass w => SimpleMenuBarClass w where+ castToSimpleMenuBar :: w -> SimpleMenuBar++ menuBarItemAdd :: SimpleMenuItemClass item => w -> item -> UIApp u ()+ menuBarItemAdd (castToSimpleMenuBar -> menuBar) (castToSimpleMenuItem -> item) = do+ getColors menuBar >>= setColors item+ menuBar `connectColorsTo` item+ addTo (_simpleMenuBarContainer menuBar) item def { fillLayoutHExpand = False }++ add' menuBar _simpleMenuBarItems item+ on_ item activated $ do+ items <- get menuBar _simpleMenuBarItems+ forM_ items $ \i ->+ set i selected False+ set item selected True++instance WidgetClass SimpleMenuBar where+ castToWidget = _simpleMenuBarParent++ overrideWidget = overrideWidgetHelper simpleMenuBarParent++instance SimpleMenuBarClass SimpleMenuBar where+ castToSimpleMenuBar = id++simpleMenuBarNew :: UIApp u SimpleMenuBar+simpleMenuBarNew = do+ _layout <- fillLayoutHorizontalNew+ container <- containerNew _layout++ itemList <- attributeNew []++ let _simpleMenuBar = SimpleMenuBar+ { _simpleMenuBarParent = castToWidget container+ , _simpleMenuBarContainer = container+ , _simpleMenuBarItems = itemList+ }++ let simpleMenuBar = overrideWidget _simpleMenuBar $+ virtualWidgetName .= "simplemenuitem"++ set simpleMenuBar colorForeground Vty.black+ set simpleMenuBar colorBackground Vty.green+ set simpleMenuBar colorForegroundSelected Vty.green+ set simpleMenuBar colorBackgroundSelected Vty.brightBlack++ return simpleMenuBar
+ src/Simple/UI/Widgets/SimpleMenuItem.hs view
@@ -0,0 +1,122 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-# LANGUAGE TemplateHaskell #-}++module Simple.UI.Widgets.SimpleMenuItem (+ SimpleMenuItem,+ SimpleMenuItemClass,+ castToSimpleMenuItem,+ simpleMenuItemNew,+ menuItemChar,+ menuItemActivate,+ activated+) where++import Control.Lens (makeLensesFor, (.=))+import qualified Graphics.Vty as Vty++import Control.Monad++import Simple.UI.Core.Attribute+import Simple.UI.Core.ListenerList+import Simple.UI.Core.UIApp+import Simple.UI.Layouts.FillLayout+import Simple.UI.Widgets.Container+import Simple.UI.Widgets.Label+import Simple.UI.Widgets.Properties.Selected+import Simple.UI.Widgets.Text+import Simple.UI.Widgets.Widget++data SimpleMenuItem = SimpleMenuItem+ { _simpleMenuItemParent :: Widget+ , _simpleMenuItemChar :: Char+ , _simpleMenuItemActivated :: ListenerList (UIApp' ())+ , _simpleMenuItemSelected :: Attribute Bool+ }++makeLensesFor [("_simpleMenuItemParent", "simpleMenuItemParent")] ''SimpleMenuItem++class WidgetClass w => SimpleMenuItemClass w where+ castToSimpleMenuItem :: w -> SimpleMenuItem++ menuItemChar :: w -> Char+ menuItemChar = _simpleMenuItemChar . castToSimpleMenuItem++ activated :: w -> ListenerList (UIApp' ())+ activated = _simpleMenuItemActivated . castToSimpleMenuItem++ menuItemActivate :: w -> UIApp u ()+ menuItemActivate item = fire (castToSimpleMenuItem item) activated ()++instance WidgetClass SimpleMenuItem where+ castToWidget = _simpleMenuItemParent++ overrideWidget = overrideWidgetHelper simpleMenuItemParent++instance SimpleMenuItemClass SimpleMenuItem where+ castToSimpleMenuItem = id++instance HasSelected SimpleMenuItem where+ selected = _simpleMenuItemSelected++simpleMenuItemNew :: Char -> String -> UIApp u SimpleMenuItem+simpleMenuItemNew c s = do+ a <- listenerNew++ _layout <- fillLayoutHorizontalNew+ container <- containerNew _layout++ l1 <- labelNew $ Just $ " [" ++ [c] ++ "] "+ l2 <- labelNew $ Just $ s ++ " "+ set l2 align TextAlignLeft++ addTo container l1 def { fillLayoutHExpand = False }+ addTo container l2 def++ sel <- attributeNew False++ let _simpleMenuItem = SimpleMenuItem+ { _simpleMenuItemParent = castToWidget container --parent+ , _simpleMenuItemChar = c+ , _simpleMenuItemActivated = a+ , _simpleMenuItemSelected = sel+ }++ let simpleMenuItem = overrideWidget _simpleMenuItem $+ virtualWidgetName .= "simplemenuitem"++ simpleMenuItem `connectColorsTo` l1+ simpleMenuItem `connectColorsTo` l2++ on_ l1 draw $ \_ _ _ -> labelSetColor simpleMenuItem l1+ on_ l2 draw $ \_ _ _ -> labelSetColor simpleMenuItem l2++ on_ simpleMenuItem keyPressed $ \key _ ->+ when (Vty.KChar c == key) $ fire simpleMenuItem activated ()++ return simpleMenuItem+ where+ labelSetColor simpleMenuItem label = do+ (fg, bg, style) <- selectedGetColors simpleMenuItem+ set label colorForeground fg+ set label colorBackground bg+ set label colorStyle style
+ src/Simple/UI/Widgets/StatusBar.hs view
@@ -0,0 +1,108 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-# LANGUAGE TemplateHaskell #-}++module Simple.UI.Widgets.StatusBar (+ StatusBar,+ castToStatusBar,+ statusBarNew,+ textLeft,+ textCenter,+ textRight+) where++import Control.Lens (makeLensesFor, (.=))+import qualified Graphics.Vty as Vty++import Simple.UI.Core.Internal.UIApp++import Simple.UI.Core.Attribute+import Simple.UI.Layouts.FillLayout+import Simple.UI.Widgets.Container+import Simple.UI.Widgets.Label+import Simple.UI.Widgets.Text+import Simple.UI.Widgets.Widget++data StatusBar = StatusBar+ { _statusBarParent :: Widget+ , _statusBarTextLeft :: Label+ , _statusBarTextCenter :: Label+ , _statusBarTextRight :: Label+ }++makeLensesFor [("_statusBarParent", "statusBarParent")] ''StatusBar++class WidgetClass w => StatusBarClass w where+ castToStatusBar :: w -> StatusBar++ textLeft :: w -> Attribute (Maybe String)+ textLeft = text . _statusBarTextLeft . castToStatusBar++ textCenter :: w -> Attribute (Maybe String)+ textCenter = text . _statusBarTextCenter . castToStatusBar++ textRight :: w -> Attribute (Maybe String)+ textRight = text . _statusBarTextRight . castToStatusBar++instance StatusBarClass StatusBar where+ castToStatusBar = id++instance WidgetClass StatusBar where+ castToWidget = _statusBarParent++ overrideWidget = overrideWidgetHelper statusBarParent++statusBarNew :: UIApp u StatusBar+statusBarNew = do+ left <- labelNew Nothing+ set left align TextAlignLeft+ center <- labelNew Nothing+ set center align TextAlignCenter+ right <- labelNew Nothing+ set right align TextAlignRight++ _layout <- fillLayoutHorizontalNew+ container <- containerNew _layout+ addTo container left def+ addTo container center def+ addTo container right def++ let _statusBar = StatusBar+ { _statusBarParent = castToWidget container+ , _statusBarTextLeft = left+ , _statusBarTextCenter = center+ , _statusBarTextRight = right+ }++ let statusBar = overrideWidget _statusBar $+ virtualWidgetName .= "statusbar"++ statusBar `connectColorsTo` left++ statusBar `connectColorsTo` center++ statusBar `connectColorsTo` right++ set statusBar colorForeground Vty.black+ set statusBar colorBackground Vty.green++ return statusBar
+ src/Simple/UI/Widgets/Text.hs view
@@ -0,0 +1,80 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-# LANGUAGE TemplateHaskell #-}++module Simple.UI.Widgets.Text (+ TextAlign (..),+ Text,+ TextClass,+ castToText,+ textNew,+ text,+ align+) where++import Control.Lens (makeLensesFor)++import Simple.UI.Core.Internal.UIApp++import Simple.UI.Core.Attribute+import Simple.UI.Widgets.Widget++data TextAlign = TextAlignLeft+ | TextAlignRight+ | TextAlignCenter++data Text = Text+ { _textParent :: Widget+ , _textText :: Attribute (Maybe String)+ , _textAlign :: Attribute TextAlign+ }++makeLensesFor [("_textParent", "textParent")] ''Text++class WidgetClass w => TextClass w where+ castToText :: w -> Text++ text :: w -> Attribute (Maybe String)+ text = _textText . castToText++ align :: w -> Attribute TextAlign+ align = _textAlign . castToText++instance TextClass Text where+ castToText = id++instance WidgetClass Text where+ castToWidget = _textParent++ overrideWidget = overrideWidgetHelper textParent++textNew :: Maybe String -> UIApp u Text+textNew s = do+ parent <- widgetNew++ t <- attributeNew s+ a <- attributeNew TextAlignLeft+ return Text+ { _textParent = parent+ , _textText = t+ , _textAlign = a+ }
+ src/Simple/UI/Widgets/TextItem.hs view
@@ -0,0 +1,103 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-# LANGUAGE TemplateHaskell #-}++module Simple.UI.Widgets.TextItem (+ TextItem,+ TextItemClass,+ castToTextItem,+ textItemNew,+ itemData+) where++import Control.Lens (makeLensesFor, (.=))+import Control.Monad (forM_)++import Simple.UI.Core.Attribute+import Simple.UI.Core.Draw+import Simple.UI.Core.ListenerList+import Simple.UI.Core.UIApp+import Simple.UI.Widgets.Properties.Selected+import Simple.UI.Widgets.Text+import Simple.UI.Widgets.Widget++data TextItem a = TextItem+ { _textItemParent :: Text+ , _textItemData :: Attribute (Maybe a)+ , _textItemSelected :: Attribute Bool+ }++makeLensesFor [("_textItemParent", "textItemParent")] ''TextItem++class TextItemClass w where+ castToTextItem :: w a -> TextItem a++ itemData :: w a -> Attribute (Maybe a)+ itemData = _textItemData . castToTextItem++instance WidgetClass (TextItem a) where+ castToWidget = castToWidget . _textItemParent++ overrideWidget = overrideWidgetHelper textItemParent++instance TextClass (TextItem a) where+ castToText = castToText . _textItemParent++instance TextItemClass TextItem where+ castToTextItem = id++instance HasSelected (TextItem a) where+ selected = _textItemSelected++textItemNew :: Maybe String -> UIApp u (TextItem a)+textItemNew s = do+ parent <- textNew s+ sel <- attributeNew False+ d <- attributeNew Nothing++ let textItem = overrideWidget+ TextItem { _textItemParent = parent+ , _textItemData = d+ , _textItemSelected = sel+ }+ $ virtualWidgetName .= "textitem"++ _ <- on textItem draw $ textItemDraw textItem++ return textItem++textItemDraw :: TextItem a -> Drawing -> Int -> Int -> UIApp u ()+textItemDraw item drawing width _ = do+ maybeText <- get item text++ (fg, bg, style) <- selectedGetColors item+ drawingRun drawing $ do+ drawingSetAttrs fg bg style+ drawingClear++ forM_ maybeText $ \_text ->+ drawingRun drawing $ do+ _align <- get item align+ case _align of+ TextAlignLeft -> drawingPutString 0 0 _text+ TextAlignRight -> drawingPutString (width - length _text) 0 _text+ TextAlignCenter -> drawingPutString ((width - length _text) `div` 2) 0 _text
+ src/Simple/UI/Widgets/TextListView.hs view
@@ -0,0 +1,277 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}++module Simple.UI.Widgets.TextListView (+ TextListView,+ TextListViewClass,+ castToTextListView,+ textListViewNew,+ textListViewCenterAt,+ textListViewReset,+ textListViewGetPos,+ textListViewGoUp,+ textListViewGoDown,+ textListViewUpdate,+ textItemActivated+) where++import Control.Lens (makeLensesFor, (.=))+import Control.Monad+import qualified Data.Vector as V+import qualified Graphics.Vty as Vty++import Simple.UI.Core.Internal.UIApp++import Simple.UI.Core.Attribute+import Simple.UI.Core.Draw+import Simple.UI.Core.ListenerList+import Simple.UI.Widgets.Text+import Simple.UI.Widgets.TextItem+import Simple.UI.Widgets.Widget++data TextListView a = TextListView+ { _textListViewParent :: Widget+ , _textListViewYOffset :: Attribute Int+ , _textListViewPos :: Attribute Int+ , _textListViewHeight :: Attribute Int+ , _textListViewItems :: Attribute (V.Vector (TextItem a))+ , _textListViewLength :: Attribute Int+ , _textListViewTextItemActivated :: ListenerList (TextItem a -> UIApp' ())+ , _textListViewContentProvider :: TextItem a -> Int -> UIApp' ()+ }++makeLensesFor [("_textListViewParent", "textListViewParent")] ''TextListView++class TextListViewClass w where+ castToTextListView :: w a -> TextListView a++ textItemActivated :: w a -> ListenerList (TextItem a -> UIApp' ())+ textItemActivated = _textListViewTextItemActivated . castToTextListView++ textListViewCenterAt :: w a -> Int -> Int -> UIApp u ()+ textListViewCenterAt _ _ 0 = return ()+ textListViewCenterAt (castToTextListView -> textListView) index listLength = do+ height <- get textListView _textListViewHeight+ let heightDivided = height `div` 2+ if | index <= heightDivided || listLength <= height -> do+ set textListView _textListViewPos index+ set textListView _textListViewYOffset 0+ | index + heightDivided < listLength -> do+ let offset = index - heightDivided+ set textListView _textListViewYOffset offset+ set textListView _textListViewPos (index - offset)+ | otherwise -> do+ let offset = listLength - height+ set textListView _textListViewYOffset offset+ set textListView _textListViewPos (index - offset)+ return ()++ textListViewReset :: w a -> UIApp u ()+ textListViewReset (castToTextListView -> textListView) = do+ set textListView _textListViewPos 0+ set textListView _textListViewYOffset 0++ textListViewGetPos :: w a -> UIApp u Int+ textListViewGetPos (castToTextListView -> textListView) = do+ pos <- get textListView _textListViewPos+ yOffset <- get textListView _textListViewYOffset+ return (pos + yOffset)++ textListViewGoUp :: w a -> UIApp u ()+ textListViewGoUp = goUp . castToTextListView++ textListViewGoDown :: w a -> UIApp u ()+ textListViewGoDown = goDown . castToTextListView++ textListViewUpdate :: w a -> UIApp u ()+ textListViewUpdate = textListViewUpdateState . castToTextListView++instance TextListViewClass TextListView where+ castToTextListView = id++instance WidgetClass (TextListView a) where+ castToWidget = castToWidget . _textListViewParent++ overrideWidget = overrideWidgetHelper textListViewParent++textListViewNew :: (TextItem a -> Int -> UIApp' ()) -> UIApp u (TextListView a)+textListViewNew contentProvider = do+ textListView <- textListViewNewOverride contentProvider++ on_ textListView draw $ textListViewDraw textListView contentProvider+ on_ textListView keyPressed $ textListViewKeyPressed textListView++ return textListView++textListViewNewOverride :: (TextItem a -> Int -> UIApp' ()) -> UIApp u (TextListView a)+textListViewNewOverride contentProvider = override <$> textListViewNewDefault contentProvider+ where+ textListViewComputeSize _ = return (1, 1)++ override textView = overrideWidget textView $ do+ virtualWidgetName .= "textlistview"+ virtualWidgetComputeSize .= textListViewComputeSize textView++textListViewNewDefault :: (TextItem a -> Int -> UIApp' ()) -> UIApp u (TextListView a)+textListViewNewDefault contentProvider = do+ parent <- widgetNew++ yOffset <- attributeNew 0+ pos <- attributeNew 0+ height <- attributeNew 0+ items <- attributeNew V.empty+ l <- attributeNew 0+ itemActivated <- listenerNew++ return TextListView+ { _textListViewParent = parent+ , _textListViewYOffset = yOffset+ , _textListViewPos = pos+ , _textListViewHeight = height+ , _textListViewItems = items+ , _textListViewLength = l+ , _textListViewTextItemActivated = itemActivated+ , _textListViewContentProvider = contentProvider+ }++textListViewDraw :: TextListView a -> (TextItem a -> Int -> UIApp' ()) -> Drawing -> Int -> Int -> UIApp u ()+textListViewDraw textListView contentProvider drawing width height = do+ oldHeight <- get textListView _textListViewHeight+ when (height /= oldHeight) $ do+ _items <- V.generateM height $ \_ -> do+ item <- textItemNew Nothing+ getColors textListView >>= setColors item+ return item+ set textListView _textListViewItems _items+ set textListView _textListViewHeight height++ textListViewUpdateState textListView++ fg <- get textListView colorForeground+ bg <- get textListView colorBackground+ selectedBg <- get textListView colorBackgroundSelected+ drawingRun drawing $ do+ drawingSetAttrs fg bg DrawStyleNormal+ drawingClear++ pos <- get textListView _textListViewPos+ yOffset <- get textListView _textListViewYOffset+ items <- get textListView _textListViewItems+ forM_ [0 .. height - 1] $ \y -> do+ let item = items V.! y+ liftUIApp' $ contentProvider item (y + yOffset)+ drawing' <- drawingSliceNew drawing 0 y width 1+ if y == pos+ then set item colorBackground selectedBg+ else set item colorBackground bg+ fire item draw (drawing', width, 1 :: Int)++textListViewUpdateState :: TextListView a -> UIApp u ()+textListViewUpdateState textListView = do+ let contentProvider = _textListViewContentProvider textListView+ items <- get textListView _textListViewItems+ height <- get textListView _textListViewHeight+ yOffset <- get textListView _textListViewYOffset++ hasText <- forM [0 .. height - 1] $ \y -> do+ let item = items V.! y+ liftUIApp' $ contentProvider item (y + yOffset)++ maybeText <- get item text+ case maybeText of+ Just _ -> return True+ Nothing -> return False++ let listLength = length $ takeWhile (== True) hasText+ set textListView _textListViewLength listLength++ pos <- get textListView _textListViewPos+ when (pos > listLength - 1) $+ if yOffset > 0+ then set textListView _textListViewYOffset (yOffset - pos + listLength - 1)+ else set textListView _textListViewPos (listLength - 1)++ when (pos < 0 && listLength > 0) $ set textListView _textListViewPos 0+++textListViewKeyPressed :: TextListView a -> Vty.Key -> [Vty.Modifier]-> UIApp u ()+textListViewKeyPressed textListView key _ = do+ height <- get textListView _textListViewHeight+ case key of+ Vty.KUp ->+ goUp textListView++ Vty.KDown ->+ goDown textListView++ Vty.KPageUp ->+ forM_ ([1..height `div` 2] :: [Int]) $ const (goUp textListView)++ Vty.KPageDown ->+ forM_ ([1..height `div` 2] :: [Int]) $ const (goDown textListView)++ Vty.KEnter -> do+ pos <- get textListView _textListViewPos+ when (pos >= 0) $ do+ items <- get textListView _textListViewItems+ fire textListView textItemActivated (items V.! pos)++ _ ->+ return ()++hasNthItem :: TextListView a -> Int -> UIApp u Bool+hasNthItem textListView pos = do+ let contentProvider = _textListViewContentProvider textListView+ item <- textItemNew Nothing+ liftUIApp' $ contentProvider item pos+ _text <- get item text+ case _text of+ Just _ -> return True+ Nothing -> return False++goUp :: TextListView a -> UIApp u ()+goUp textListView = do+ pos <- get textListView _textListViewPos+ yOffset <- get textListView _textListViewYOffset+ if pos > 0+ then+ set textListView _textListViewPos (pos - 1)+ else+ when (yOffset > 0) $+ modify textListView _textListViewYOffset pred++goDown :: TextListView a -> UIApp u ()+goDown textListView = do+ l <- get textListView _textListViewLength+ pos <- get textListView _textListViewPos+ yOffset <- get textListView _textListViewYOffset+ if l > pos + 1+ then+ set textListView _textListViewPos (pos + 1)+ else do+ hasItem <- hasNthItem textListView (pos + yOffset + 1)+ when hasItem $+ modify textListView _textListViewYOffset succ
+ src/Simple/UI/Widgets/TextView.hs view
@@ -0,0 +1,172 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-# LANGUAGE TemplateHaskell #-}++module Simple.UI.Widgets.TextView (+ TextView,+ TextViewClass,+ castToTextView,+ textViewNew+) where++import Control.Lens (makeLensesFor, (.=))+import Control.Monad+import qualified Graphics.Vty as Vty++import Simple.UI.Core.Internal.UIApp++import Simple.UI.Core.Attribute+import Simple.UI.Core.Draw+import Simple.UI.Core.ListenerList+import Simple.UI.Widgets.Text+import Simple.UI.Widgets.Widget++data TextView = TextView+ { _textViewParent :: Text+ , _textViewYOffset :: Attribute Int+ , _textViewHeight :: Attribute Int+ }++makeLensesFor [("_textViewParent", "textViewParent")] ''TextView++class TextClass w => TextViewClass w where+ castToTextView :: w -> TextView++instance TextViewClass TextView where+ castToTextView = id++instance TextClass TextView where+ castToText = _textViewParent++instance WidgetClass TextView where+ castToWidget = castToWidget . _textViewParent++ overrideWidget = overrideWidgetHelper textViewParent++textViewNew :: Maybe String -> UIApp u TextView+textViewNew s = do+ textView <- textViewNewOverride s++ on_ textView draw $ textViewDraw textView+ on_ textView keyPressed $ textViewKeyPressed textView++ return textView++textViewNewOverride :: Maybe String -> UIApp u TextView+textViewNewOverride s = override <$> textViewNewDefault s+ where+ textViewComputeSize textView = do+ maybeText <- get textView text++ case maybeText of+ Nothing -> return (1, 1)+ Just _text -> do+ let ls = lines _text+ let ws = map length ls++ let w = maximum ws+ let l = length ls++ return ( if w == 0 then 1 else w+ , if l == 0 then 1 else l+ )++ override textView = overrideWidget textView $ do+ virtualWidgetName .= "textview"+ virtualWidgetComputeSize .= textViewComputeSize textView++textViewNewDefault :: Maybe String -> UIApp u TextView+textViewNewDefault s = do+ parent <- textNew s++ yOffset <- attributeNew 0+ height <- attributeNew 0++ return TextView+ { _textViewParent = parent+ , _textViewYOffset = yOffset+ , _textViewHeight = height+ }++textViewDraw :: TextView -> Drawing -> Int -> Int -> UIApp u ()+textViewDraw textView drawing _ height = do+ set textView _textViewHeight height+ maybeText <- get textView text++ forM_ maybeText $ \_text -> do+ fg <- get textView colorForeground+ bg <- get textView colorBackground+ style <- get textView colorStyle++ let ls = lines _text+ let l = length ls++ yOffset' <- get textView _textViewYOffset+ let yOffset = if height + yOffset' > l+ then nat $ l - height+ else yOffset'++ drawingRun drawing $ do+ let minH = min height l+ let h = height - l+ let dy = if h <= 0 then 0 else h `div` 2++ drawingSetAttrs fg bg style+ drawingClear+ forM_ (zip [dy..] [0 .. minH - 1]) $ \(y, i) ->+ drawingPutString 0 y (ls !! (i + yOffset))++textViewKeyPressed :: TextView -> Vty.Key -> [Vty.Modifier]-> UIApp u ()+textViewKeyPressed textView key _ = do+ height <- get textView _textViewHeight+ yOffset <- get textView _textViewYOffset++ case key of+ Vty.KUp ->+ when (yOffset > 0) $+ set textView _textViewYOffset (yOffset - 1)++ Vty.KDown -> do+ maybeText <- get textView text+ forM_ maybeText $ \_text -> do+ let l = length . lines $ _text+ when (l - height > yOffset) $+ set textView _textViewYOffset (yOffset + 1)++ Vty.KPageUp ->+ if yOffset > 5+ then set textView _textViewYOffset (yOffset - 5)+ else set textView _textViewYOffset 0++ Vty.KPageDown -> do+ maybeText <- get textView text+ forM_ maybeText $ \_text -> do+ let l = length . lines $ _text+ if l - height > yOffset + 5+ then set textView _textViewYOffset (yOffset + 5)+ else set textView _textViewYOffset (nat $ l - height)++ _ ->+ return ()++nat :: Int -> Int+nat x = if x < 0 then 0 else x
+ src/Simple/UI/Widgets/Widget.hs view
@@ -0,0 +1,201 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2017 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}++module Simple.UI.Widgets.Widget (+ WidgetClass,+ Widget,+ castToWidget,+ overrideWidget,+ overrideWidgetHelper,+ overrideHelper,+ widgetNew,+ connectColorsTo,+ keyPressed,+ draw,+ colorForeground,+ colorBackground,+ colorStyle,+ colorForegroundSelected,+ colorBackgroundSelected,+ colorStyleSelected,+ enabled,+ visible,+ name,+ computeSize,+ setColors,+ getColors,+ virtualWidgetName,+ virtualWidgetComputeSize+) where++import qualified Graphics.Vty as Vty++import Control.Lens (Lens', makeLenses, (&), (.~),+ (^.))+import Control.Monad.State.Strict (State, execState)+import Simple.UI.Core.Attribute+import Simple.UI.Core.Draw+import Simple.UI.Core.Internal.UIApp+import Simple.UI.Core.ListenerList++data Widget = Widget+ { _widgetKeyPressed :: ListenerList (Vty.Key -> [Vty.Modifier]-> UIApp' ())+ , _widgetDraw :: ListenerList (Drawing -> Int -> Int -> UIApp' ())+ , _widgetColorForeground :: Attribute Vty.Color+ , _widgetColorBackground :: Attribute Vty.Color+ , _widgetColorStyle :: Attribute DrawStyle+ , _widgetColorForegroundSelected :: Attribute Vty.Color+ , _widgetColorBackgroundSelected :: Attribute Vty.Color+ , _widgetColorStyleSelected :: Attribute DrawStyle+ , _widgetEnabled :: Attribute Bool+ , _widgetVisible :: Attribute Bool+ --+ , _widgetName :: String+ , _widgetComputeSize :: UIApp' (Int, Int)+ }++data VirtualWidget = VirtualWidget+ { _virtualWidgetName :: String+ , _virtualWidgetComputeSize :: UIApp' (Int, Int)+ }++makeLenses ''VirtualWidget++class WidgetClass w where+ castToWidget :: w -> Widget++ overrideWidget :: w -> State VirtualWidget () -> w++ keyPressed :: w -> ListenerList (Vty.Key -> [Vty.Modifier]-> UIApp' ())+ keyPressed = _widgetKeyPressed . castToWidget++ draw :: w -> ListenerList (Drawing -> Int -> Int -> UIApp' ())+ draw = _widgetDraw . castToWidget++ colorForeground :: w -> Attribute Vty.Color+ colorForeground = _widgetColorForeground . castToWidget++ colorBackground :: w -> Attribute Vty.Color+ colorBackground = _widgetColorBackground . castToWidget++ colorStyle :: w -> Attribute DrawStyle+ colorStyle = _widgetColorStyle . castToWidget++ colorForegroundSelected :: w -> Attribute Vty.Color+ colorForegroundSelected = _widgetColorForegroundSelected . castToWidget++ colorBackgroundSelected :: w -> Attribute Vty.Color+ colorBackgroundSelected = _widgetColorBackgroundSelected . castToWidget++ colorStyleSelected :: w -> Attribute DrawStyle+ colorStyleSelected = _widgetColorStyleSelected . castToWidget++ enabled :: w -> Attribute Bool+ enabled = _widgetEnabled . castToWidget++ visible :: w -> Attribute Bool+ visible = _widgetVisible . castToWidget++ name :: w -> String+ name = _widgetName . castToWidget++ computeSize :: w -> UIApp u (Int, Int)+ computeSize = liftUIApp' . _widgetComputeSize . castToWidget++instance WidgetClass Widget where+ castToWidget = id++ overrideWidget widget m = widget+ { _widgetName = _virtualWidgetName s+ , _widgetComputeSize = _virtualWidgetComputeSize s+ }+ where+ s = execState m VirtualWidget+ { _virtualWidgetName = name widget+ , _virtualWidgetComputeSize = computeSize widget+ }++widgetNew :: UIApp u Widget+widgetNew = do+ p <- listenerNew+ d <- listenerNew+ fgColor <- attributeNew Vty.white+ bgColor <- attributeNew Vty.black+ style <- attributeNew DrawStyleNormal+ selFgColor <- attributeNew Vty.white+ selBgColor <- attributeNew Vty.brightBlack+ selStyle <- attributeNew DrawStyleNormal+ en <- attributeNew True+ v <- attributeNew True+ return Widget+ { _widgetKeyPressed = p+ , _widgetDraw = d+ , _widgetColorForeground = fgColor+ , _widgetColorBackground = bgColor+ , _widgetColorStyle = style+ , _widgetColorForegroundSelected = selFgColor+ , _widgetColorBackgroundSelected = selBgColor+ , _widgetColorStyleSelected = selStyle+ , _widgetEnabled = en+ , _widgetVisible = v+ , _widgetName = "widget"+ , _widgetComputeSize = return (1, 1)+ }++overrideHelper :: WidgetClass p => (p -> State s () -> p) -> Lens' w p -> w -> State s () -> w+overrideHelper overrideFunc parentLens widget f = widget & parentLens .~ overrideFunc parent f+ where+ parent = widget ^. parentLens++overrideWidgetHelper :: WidgetClass p => Lens' w p -> w -> State VirtualWidget () -> w+overrideWidgetHelper = overrideHelper overrideWidget++connectColorsTo :: (WidgetClass w, WidgetClass v) => w -> v -> UIApp u ()+connectColorsTo (castToWidget -> widget) (castToWidget -> vidget) = do+ colorForeground widget `connectAttrTo` colorForeground vidget+ colorBackground widget `connectAttrTo` colorBackground vidget+ colorStyle widget `connectAttrTo` colorStyle vidget+ colorForegroundSelected widget `connectAttrTo` colorForegroundSelected vidget+ colorBackgroundSelected widget `connectAttrTo` colorBackgroundSelected vidget+ colorStyleSelected widget `connectAttrTo` colorStyleSelected vidget++setColors :: WidgetClass w => w -> (Vty.Color, Vty.Color, DrawStyle, Vty.Color, Vty.Color, DrawStyle) -> UIApp u ()+setColors widget (foreground, background, style, selForeground, selBackground, selStyle) = do+ set widget colorForeground foreground+ set widget colorBackground background+ set widget colorStyle style+ set widget colorForegroundSelected selForeground+ set widget colorBackgroundSelected selBackground+ set widget colorStyleSelected selStyle++getColors :: WidgetClass w => w -> UIApp u (Vty.Color, Vty.Color, DrawStyle, Vty.Color, Vty.Color, DrawStyle)+getColors widget = do+ foreground <- get widget colorForeground+ background <- get widget colorBackground+ style <- get widget colorStyle+ selForeground <- get widget colorForegroundSelected+ selBackground <- get widget colorBackgroundSelected+ selStyle <- get widget colorStyleSelected+ return (foreground, background, style, selForeground, selBackground, selStyle)
+ src/Simple/UI/Widgets/Widget.hs-boot view
@@ -0,0 +1,25 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2018 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module Simple.UI.Widgets.Widget where++data Widget
+ src/Simple/UI/Widgets/Window.hs view
@@ -0,0 +1,91 @@+{-+ * Programmer: Piotr Borek+ * E-mail: piotrborek@op.pl+ * Copyright 2016 Piotr Borek+ *+ * Distributed under the terms of the GPL (GNU Public License)+ *+ * This program is free software; you can redistribute it and/or modify+ * it under the terms of the GNU General Public License as published by+ * the Free Software Foundation; either version 2 of the License, or+ * (at your option) any later version.+ *+ * This program is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ * GNU General Public License for more details.+ *+ * You should have received a copy of the GNU General Public License+ * along with this program; if not, write to the Free Software+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-# LANGUAGE TemplateHaskell #-}++module Simple.UI.Widgets.Window (+ WindowType (..),+ Window,+ WindowClass,+ castToWindow,+ windowNew,+ windowType,+ windowFocus+) where++import Control.Lens (makeLensesFor, (.=))+import Simple.UI.Core.Internal.UIApp++import Simple.UI.Core.Attribute+import Simple.UI.Widgets.Container+import Simple.UI.Widgets.Widget++data WindowType = WindowTypeTopLevel+ | WindowTypeDialog+ deriving (Eq, Show)++data Window a = Window+ { _windowParent :: Container a+ , _windowType :: WindowType+ , _windowFocus :: Attribute Bool+ }++makeLensesFor [("_windowParent", "windowParent")] ''Window++class ContainerClass w => WindowClass w where+ castToWindow :: w a -> Window a++ windowType :: WindowClass w => w a -> WindowType+ windowType = _windowType . castToWindow++ windowFocus :: WindowClass w => w a -> Attribute Bool+ windowFocus = _windowFocus . castToWindow++instance WindowClass Window where+ castToWindow = id++instance ContainerClass Window where+ castToContainer = _windowParent++instance WidgetClass (Window a) where+ castToWidget = castToWidget . castToContainer++ overrideWidget = overrideWidgetHelper windowParent++windowNew :: LayoutClass a => WindowType -> a -> UIApp u (Window a)+windowNew = windowNewOverride++windowNewOverride :: LayoutClass a => WindowType -> a -> UIApp u (Window a)+windowNewOverride t _layout = override <$> windowNewDefault t _layout+ where+ override window = overrideWidget window $+ virtualWidgetName .= "window"++windowNewDefault :: LayoutClass a => WindowType -> a -> UIApp u (Window a)+windowNewDefault t _layout = do+ parent <- containerNew _layout+ focusLens <- attributeNew False++ return Window+ { _windowParent = parent+ , _windowType = t+ , _windowFocus = focusLens+ }
+ stack.yaml view
@@ -0,0 +1,6 @@+resolver: lts-9.21+packages:+- '.'+flags: {}+extra-package-dbs: []+allow-newer: true