diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,1 @@ +GPL diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/simple-ui.cabal b/simple-ui.cabal new file mode 100644 --- /dev/null +++ b/simple-ui.cabal @@ -0,0 +1,64 @@ +name: simple-ui +version: 0.1.0 +cabal-version: >=1.22 +build-type: Simple +author: Piotr Borek +maintainer: Piotr Borek +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 diff --git a/src/Simple/Locale/Languages.hs b/src/Simple/Locale/Languages.hs new file mode 100644 --- /dev/null +++ b/src/Simple/Locale/Languages.hs @@ -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 diff --git a/src/Simple/Locale/Translate.hs b/src/Simple/Locale/Translate.hs new file mode 100644 --- /dev/null +++ b/src/Simple/Locale/Translate.hs @@ -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 diff --git a/src/Simple/Locale/TranslateClass.hs b/src/Simple/Locale/TranslateClass.hs new file mode 100644 --- /dev/null +++ b/src/Simple/Locale/TranslateClass.hs @@ -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 diff --git a/src/Simple/Locale/TranslateTH.hs b/src/Simple/Locale/TranslateTH.hs new file mode 100644 --- /dev/null +++ b/src/Simple/Locale/TranslateTH.hs @@ -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)) + ) + ) diff --git a/src/Simple/UI/All.hs b/src/Simple/UI/All.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/All.hs @@ -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 diff --git a/src/Simple/UI/Core/Attribute.hs b/src/Simple/UI/Core/Attribute.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Core/Attribute.hs @@ -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) +-} diff --git a/src/Simple/UI/Core/Draw.hs b/src/Simple/UI/Core/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Core/Draw.hs @@ -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 diff --git a/src/Simple/UI/Core/Internal/UIApp.hs b/src/Simple/UI/Core/Internal/UIApp.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Core/Internal/UIApp.hs @@ -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 diff --git a/src/Simple/UI/Core/ListenerList.hs b/src/Simple/UI/Core/ListenerList.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Core/ListenerList.hs @@ -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) diff --git a/src/Simple/UI/Core/UIApp.hs b/src/Simple/UI/Core/UIApp.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Core/UIApp.hs @@ -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) diff --git a/src/Simple/UI/Layouts/FillLayout.hs b/src/Simple/UI/Layouts/FillLayout.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Layouts/FillLayout.hs @@ -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 diff --git a/src/Simple/UI/Layouts/SingleLayout.hs b/src/Simple/UI/Layouts/SingleLayout.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Layouts/SingleLayout.hs @@ -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 diff --git a/src/Simple/UI/Utils.hs b/src/Simple/UI/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Utils.hs @@ -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) diff --git a/src/Simple/UI/Widgets/Container.hs b/src/Simple/UI/Widgets/Container.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Widgets/Container.hs @@ -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 + } diff --git a/src/Simple/UI/Widgets/Edit.hs b/src/Simple/UI/Widgets/Edit.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Widgets/Edit.hs @@ -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 ' ' diff --git a/src/Simple/UI/Widgets/Label.hs b/src/Simple/UI/Widgets/Label.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Widgets/Label.hs @@ -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 diff --git a/src/Simple/UI/Widgets/Properties/Selected.hs b/src/Simple/UI/Widgets/Properties/Selected.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Widgets/Properties/Selected.hs @@ -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) diff --git a/src/Simple/UI/Widgets/SimpleMenuBar.hs b/src/Simple/UI/Widgets/SimpleMenuBar.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Widgets/SimpleMenuBar.hs @@ -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 diff --git a/src/Simple/UI/Widgets/SimpleMenuItem.hs b/src/Simple/UI/Widgets/SimpleMenuItem.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Widgets/SimpleMenuItem.hs @@ -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 diff --git a/src/Simple/UI/Widgets/StatusBar.hs b/src/Simple/UI/Widgets/StatusBar.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Widgets/StatusBar.hs @@ -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 diff --git a/src/Simple/UI/Widgets/Text.hs b/src/Simple/UI/Widgets/Text.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Widgets/Text.hs @@ -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 + } diff --git a/src/Simple/UI/Widgets/TextItem.hs b/src/Simple/UI/Widgets/TextItem.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Widgets/TextItem.hs @@ -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 diff --git a/src/Simple/UI/Widgets/TextListView.hs b/src/Simple/UI/Widgets/TextListView.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Widgets/TextListView.hs @@ -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 diff --git a/src/Simple/UI/Widgets/TextView.hs b/src/Simple/UI/Widgets/TextView.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Widgets/TextView.hs @@ -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 diff --git a/src/Simple/UI/Widgets/Widget.hs b/src/Simple/UI/Widgets/Widget.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Widgets/Widget.hs @@ -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) diff --git a/src/Simple/UI/Widgets/Widget.hs-boot b/src/Simple/UI/Widgets/Widget.hs-boot new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Widgets/Widget.hs-boot @@ -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 diff --git a/src/Simple/UI/Widgets/Window.hs b/src/Simple/UI/Widgets/Window.hs new file mode 100644 --- /dev/null +++ b/src/Simple/UI/Widgets/Window.hs @@ -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 + } diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,6 @@ +resolver: lts-9.21 +packages: +- '.' +flags: {} +extra-package-dbs: [] +allow-newer: true