lui 0.0.2 → 0.0.3

raw patch · 14 files changed

+158/−176 lines, 14 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• lui.cabal +2/−2
• src/Example.hs +3/−15
• src/Graphics/UI/LUI/Draw.hs +0/−85
• src/Graphics/UI/LUI/Image.hs +63/−0
• src/Graphics/UI/LUI/Run.hs +3/−3
• src/Graphics/UI/LUI/Widget.hs +4/−3
• src/Graphics/UI/LUI/Widgets/Adapter.hs +1/−1
• src/Graphics/UI/LUI/Widgets/FocusDelegator.hs +10/−12
• src/Graphics/UI/LUI/Widgets/Grid.hs +35/−34
• src/Graphics/UI/LUI/Widgets/KeysTable.hs +11/−0
• src/Graphics/UI/LUI/Widgets/Space.hs +5/−3
• src/Graphics/UI/LUI/Widgets/TextEdit.hs +17/−14
• src/Graphics/UI/LUI/Widgets/TextView.hs +3/−3
• src/Graphics/UI/LUI/Widgets/Unfocusable.hs +1/−1

@@ -1,5 +1,5 @@ Name:                lui-Version:             0.0.2+Version:             0.0.3 Cabal-Version:       >= 1.2 Synopsis:            Purely FunctionaL User Interface Category:            graphics@@ -29,7 +29,7 @@   Extensions:   Build-Depends:       base, haskell98, containers, mtl, SDL, haskgame, MaybeT   Exposed-Modules:     Graphics.UI.LUI.Accessor,-                       Graphics.UI.LUI.Draw,+                       Graphics.UI.LUI.Image,                        Graphics.UI.LUI.Run,                        Graphics.UI.LUI.Widget,                        Graphics.UI.LUI.Widgets.Adapter,

@@ -37,7 +37,6 @@ data Model = Model     {       vboxModel :: Box.DelegatedMutable-    , hboxModel :: Box.Mutable     , textEditModels :: Map.Map Grid.Cursor TextEdit.DelegatedMutable     , gridModel :: Grid.DelegatedMutable     }@@ -50,8 +49,6 @@ -- TODO: Replace with TH auto-gen avboxModel :: Accessor Model Box.DelegatedMutable avboxModel = accessor vboxModel (\new x -> x{vboxModel=new})-ahboxModel :: Accessor Model Box.Mutable-ahboxModel = accessor hboxModel (\new x -> x{hboxModel=new}) atextEditModels :: Accessor Model (Map.Map Grid.Cursor TextEdit.DelegatedMutable) atextEditModels = accessor textEditModels (\new x -> x{textEditModels=new}) agridModel :: Accessor Model Grid.DelegatedMutable@@ -71,7 +68,6 @@     Model     {       vboxModel = Box.delegatedMutable False 0-    , hboxModel = Box.Mutable 0     , textEditModels =       Map.fromList [((x, y),                      TextEdit.delegatedMutable False (texts!!(y*2+x)) 5)@@ -96,13 +92,12 @@                           (defaultFont fonts)                           textEditColor $                           atextEditModels ^> aMapValue cursor-                            textView :: String -> Fonts -> Widget Model textView text fonts =     TextView.new textViewColor (textViewFont fonts) text -grid, hbox, vbox, keysTable, proxy1, proxy2 :: Fonts -> Widget Model+grid, vbox, withKeysTable, proxy1, proxy2 :: Fonts -> Widget Model  gridSize :: Grid.Cursor gridSize = (2, 2)@@ -114,13 +109,6 @@               [((x, y), Grid.Item (textEdit (x, y) fonts) (0.5, 1))                | x <- [0..1], y <- [0..1]] -hbox fonts =-    Box.new Box.Horizontal items ahboxModel-    where-      items = [Box.Item (vbox fonts) 0.5-              ,Box.Item (Space.newW 50) 0-              ,Box.Item (keysTable fonts) 0]- vbox fonts = Box.newDelegated Box.Vertical items avboxModel     where       items = [Box.Item (grid fonts) 1@@ -129,7 +117,7 @@               ,Box.Item (textView "This is just a view" fonts) 0.5               ,Box.Item (proxy2 fonts) 0.5] -keysTable fonts = KeysTable.newForWidget (keysFont fonts) (descFont fonts) (hbox fonts)+withKeysTable fonts = KeysTable.newBoxedWidget Box.Horizontal 50 (keysFont fonts) (descFont fonts) (vbox fonts)  proxy1 fonts model =     textEdit (model ^. agridModel ^. Grid.aDelegatedMutableCursor) fonts model@@ -158,4 +146,4 @@ makeGui :: IO (Widget Model) makeGui = do   [f15, f25, f30] <- mapM Font.defaultFont [15, 25, 30]-  return . hbox $ Fonts f30 f15 f25 f25+  return . withKeysTable $ Fonts f30 f15 f25 f25

@@ -1,85 +0,0 @@-{-# OPTIONS -Wall -O2-  -XGeneralizedNewtypeDeriving-  #-}--module Graphics.UI.LUI.Draw-    (Position,Size-    -- The monads-    ,Draw-    ,Compute-    -- Monad runners-    ,render-    ,computeResult-    -- Compute primitives-    ,textSize-    -- Draw primitives-    ,computeToDraw-    ,text-    ,rect-    ,move-    ) where--import qualified Graphics.UI.HaskGame as HaskGame-import qualified Graphics.UI.HaskGame.Font as Font-import qualified Graphics.UI.HaskGame.Rect as Rect-import Graphics.UI.HaskGame.Vector2(Vector2(..))-import Graphics.UI.HaskGame.Color(Color)-import Graphics.UI.HaskGame.Font(Font)--import Control.Monad.Trans(lift)-import Control.Monad.Reader(ReaderT, ask, local, runReaderT)--type Position = Vector2 Int-type Size = Vector2 Int--newtype Compute a = Compute { unCompute :: IO a }-    deriving Monad-liftIO :: IO a -> Compute a-liftIO = Compute---- Monad Transformers require a bit of boiler-plate...-newtype Draw a = Draw { unDraw :: ReaderT HaskGame.Surface (ReaderT Position Compute) a }-    deriving Monad-liftPosition :: ReaderT Position Compute a -> Draw a-liftPosition = Draw . lift-liftSurface :: ReaderT HaskGame.Surface (ReaderT Position Compute) a -> Draw a-liftSurface = Draw--computeToDraw :: Compute a -> Draw a-computeToDraw = Draw . lift . lift--computeResult :: Compute a -> IO a-computeResult = unCompute--render :: HaskGame.Surface -> Position -> Draw a -> IO a-render surface pos = computeResult .-                     flip runReaderT pos .-                     flip runReaderT surface .-                     unDraw--textSize :: Font -> String -> Compute Size-textSize font str = do-  liftIO $ Font.textSize font str--text :: Color -> Font -> String -> Draw Size-text color font str = do-  surface <- liftSurface ask-  position <- liftPosition ask-  computeToDraw $ do-    textSurface <- liftIO $ Font.renderText font str color-    liftIO $ HaskGame.blit surface position textSurface-    textSize font str-  -rect :: Color -> Size -> Draw Size-rect color size = do-  surface <- liftSurface $ ask-  position <- liftPosition ask-  let r = Rect.makeRect position size-  computeToDraw . liftIO $ HaskGame.fillRect surface r color-  return size--move :: Position -> Draw a -> Draw a-move delta (Draw act) = do-  surface <- liftSurface $ ask-  let posReaderT = flip runReaderT surface act-  liftPosition $ local (+delta) posReaderT

@@ -0,0 +1,63 @@+{-# OPTIONS -Wall -O2+  #-}++module Graphics.UI.LUI.Image+    (-- The compositional interface:+     Image+    ,text+    ,textSize+    ,rect+    ,move+    -- The implementational interface+    ,Pos,render+    ) where++import qualified Graphics.UI.HaskGame as HaskGame+import qualified Graphics.UI.HaskGame.Font as Font+import qualified Graphics.UI.HaskGame.Rect as Rect+import Graphics.UI.HaskGame(Surface)+import Graphics.UI.HaskGame.Vector2(Vector2(..))+import Graphics.UI.HaskGame.Color(Color)+import Graphics.UI.HaskGame.Font(Font)+import Graphics.UI.HaskGame(Size)+import Data.Monoid(Monoid(..))++type Pos = Vector2 Int++-- Image semantically represents an infinite map from pixel index to+-- color.+newtype Image = Image+    {+      render :: Surface -> Pos -> IO ()+    }++instance Monoid Image where+    mempty = Image $ const . const . return $ ()+    Image xdraw `mappend` Image ydraw = Image draw+        where+          draw surface pos = do+            xdraw surface pos+            ydraw surface pos++-- Re-export this to match text below+textSize :: Font -> String -> Size+textSize = Font.textSize++text :: Color -> Font -> String -> Image+text color font str = Image draw+    where+      draw surface pos = do+        textSurface <- Font.renderText font str color+        HaskGame.blit surface pos textSurface++rect :: Color -> Size -> Image+rect color size = Image draw+    where+      draw surface pos = do+        HaskGame.fillRect surface (Rect.makeRect pos size) color++move :: Pos -> Image -> Image+move delta image = Image draw+    where+      draw surface pos = do+        render image surface (pos + delta)

@@ -4,7 +4,7 @@ module Graphics.UI.LUI.Run(mainLoop) where -import qualified Graphics.UI.LUI.Draw as Draw+import qualified Graphics.UI.LUI.Image as Image import qualified Graphics.UI.LUI.Widget as Widget import Graphics.UI.LUI.Widget(Widget, WidgetFuncs(..)) @@ -68,8 +68,8 @@         HaskGame.fillSurface display (Color 0 0 0)         if handledEvent || shouldDraw           then do-            let draw = widgetDraw (widget model) (Widget.DrawInfo True)-            Draw.render display (Vector2 0 0) draw+            let draw = widgetImage (widget model) (Widget.DrawInfo True)+            Image.render draw display $ Vector2 0 0             SDL.flip display           else             SDL.delay 20

@@ -13,9 +13,10 @@     ) where -import Graphics.UI.LUI.Draw(Draw, Compute, Size)+import Graphics.UI.LUI.Image(Image) import Graphics.UI.LUI.Accessor(Accessor) +import Graphics.UI.HaskGame(Size) import qualified Graphics.UI.HaskGame.Key as Key  import qualified Data.Map as Map@@ -36,8 +37,8 @@ -- TODO: Consider moving the model argument outside of the record data WidgetFuncs model = WidgetFuncs     {-      widgetDraw :: DrawInfo -> Draw Size-    , widgetSize :: DrawInfo -> Compute Size+      widgetImage :: DrawInfo -> Image+    , widgetSize :: DrawInfo -> Size     , widgetGetKeymap :: Maybe (ActionHandlers model)     } 

@@ -18,7 +18,7 @@     in       WidgetFuncs       {-        widgetDraw = widgetDraw widgetFuncs+        widgetImage = widgetImage widgetFuncs       , widgetSize = widgetSize widgetFuncs       , widgetGetKeymap =           let keymap = widgetGetKeymap widgetFuncs

@@ -13,7 +13,7 @@ where  import qualified Graphics.UI.LUI.Widget as Widget-import qualified Graphics.UI.LUI.Draw as Draw+import qualified Graphics.UI.LUI.Image as Image import Graphics.UI.LUI.Widget(Widget, WidgetFuncs(..))  import Graphics.UI.LUI.Func(result)@@ -27,6 +27,7 @@ import qualified Data.Map as Map import Control.Arrow(second) import Data.Maybe(fromMaybe)+import Data.Monoid(Monoid(..))  -- TODO: Use record instead of tuple so auto-TH creates the accessors: type DelegatedMutable mutable = (Mutable, mutable)@@ -58,10 +59,11 @@ newWith focusColor startStr stopStr childWidget acc model =     let Mutable delegating = model ^. acc         childWidgetFuncs = childWidget model+        childWidgetSize = widgetSize childWidgetFuncs     in WidgetFuncs     {-      widgetSize = \drawInfo -> widgetSize childWidgetFuncs drawInfo-    , widgetDraw = \drawInfo -> do+      widgetSize = childWidgetSize+    , widgetImage = \drawInfo ->         let              haveFocus = Widget.diHasFocus drawInfo             delegatorHasFocus = haveFocus && not delegating@@ -69,15 +71,11 @@                             {                               Widget.diHasFocus = haveFocus && delegating                             }-        if delegatorHasFocus-          then do-            size <- Draw.computeToDraw $-                    widgetSize childWidgetFuncs childDrawInfo-            Draw.rect focusColor size-            return ()-          else-            return ()-        widgetDraw childWidgetFuncs childDrawInfo+        in (if delegatorHasFocus+            then Image.rect focusColor $ childWidgetSize childDrawInfo+            else mempty)+           `mappend`+           widgetImage childWidgetFuncs childDrawInfo     , widgetGetKeymap =         let mChildKeymap = widgetGetKeymap childWidgetFuncs             childKeymap = fromMaybe Map.empty mChildKeymap

@@ -18,7 +18,7 @@  import qualified Graphics.UI.LUI.Widget as Widget import qualified Graphics.UI.LUI.Widgets.FocusDelegator as FocusDelegator-import qualified Graphics.UI.LUI.Draw as Draw+import qualified Graphics.UI.LUI.Image as Image  import Graphics.UI.LUI.Widget(Widget, WidgetFuncs(..)) @@ -35,11 +35,10 @@                                    ,vector2fst,vector2snd)  import qualified Data.Map as Map-import Control.Monad(forM_, forM) import Control.Arrow(second, (***)) import Data.List(transpose)-import Data.Maybe(isJust, fromMaybe)-import Data.Maybe(isNothing)+import Data.Maybe(isJust, isNothing, fromMaybe)+import Data.Monoid(mempty, mconcat)  data Item model = Item     {@@ -74,20 +73,21 @@     Widget.DrawInfo (drawInfo && cursor==itemIndex)  getRowColumnSizes :: model -> Mutable -> Items model -> Cursor -> Widget.DrawInfo ->-                     Draw.Compute ([Int], [Int])-getRowColumnSizes model mutable items size drawInfo = do-  rowsSizes <- forM (gridRows size items) . mapM $ \(itemIndex, mItem) ->-                   case mItem of-                     Nothing -> return $ Vector2 0 0-                     Just item ->-                         widgetSize ((itemWidget item) model)-                                    (gridDrawInfo mutable itemIndex drawInfo)+                     ([Int], [Int])+getRowColumnSizes model mutable items size drawInfo = (rowHeights, columnWidths)+    where+      mapItems = map . map+      rowsSizes = mapItems itemWidgetSize (gridRows size items)+      itemWidgetSize (itemIndex, mItem) =+        case mItem of+          Nothing -> Vector2 0 0+          Just item -> widgetSize (itemWidget item model)+                                  (gridDrawInfo mutable itemIndex drawInfo)+      rowsHeights = mapItems vector2snd rowsSizes+      rowsWidths =  mapItems vector2fst rowsSizes -  let rowsHeights = (map . map) vector2snd rowsSizes-      rowsWidths = (map . map) vector2fst rowsSizes-      rowHeights = map maximum $ rowsHeights+      rowHeights =   map maximum             $ rowsHeights       columnWidths = map maximum . transpose $ rowsWidths-  return (rowHeights, columnWidths)  mutableCursorApply :: (Cursor -> Cursor) -> Mutable -> Mutable mutableCursorApply func (Mutable oldCursor) = Mutable $ func oldCursor@@ -173,29 +173,30 @@         rowColumnSizes drawInfo = getRowColumnSizes model mutable items size drawInfo     in WidgetFuncs     {-      widgetDraw = \drawInfo -> do-        (rowHeights, columnWidths) <- Draw.computeToDraw . rowColumnSizes $ drawInfo-        forM_ (zip (posSizes rowHeights) rows) $-          \((ypos, height), row) -> do-            forM_ (zip (posSizes columnWidths) row) $-              \((xpos, width), (itemIndex, mItem)) ->-                case mItem of-                  Nothing -> return ()-                  Just item -> do+      widgetImage = \drawInfo -> let+        (rowHeights, columnWidths) = rowColumnSizes drawInfo+        images =+          flip map (zip (posSizes rowHeights) rows) $+          \((ypos, height), row) ->+            flip map (zip (posSizes columnWidths) row) $+            \((xpos, width), (itemIndex, mItem)) ->+              case mItem of+                Nothing -> mempty+                Just item ->                     let Item childWidget (ax, ay) = item                         childDrawInfo = gridDrawInfo mutable itemIndex drawInfo                         childWidgetFuncs = childWidget model-                    Vector2 w h <- Draw.computeToDraw $-                                   widgetSize childWidgetFuncs childDrawInfo-                    let pos = Vector2 (xpos + inFrac (*ax) (width-w))+                        childImage = widgetImage childWidgetFuncs childDrawInfo+                        Vector2 w h = widgetSize childWidgetFuncs childDrawInfo+                        pos = Vector2 (xpos + inFrac (*ax) (width-w))                                       (ypos + inFrac (*ay) (height-h))-                    Draw.move pos $ widgetDraw childWidgetFuncs childDrawInfo-                    return ()-        return $ Vector2 (sum columnWidths) (sum rowHeights)+                    in Image.move pos childImage+        in mconcat . concat $ images -    , widgetSize = \drawInfo -> do-      (rowHeights, columnWidths) <- rowColumnSizes drawInfo-      return $ Vector2 (sum columnWidths) (sum rowHeights)+    , widgetSize =+        \drawInfo ->+            let (rowHeights, columnWidths) = rowColumnSizes drawInfo+            in Vector2 (sum columnWidths) (sum rowHeights)      , widgetGetKeymap =       if all isNothing .

@@ -7,10 +7,12 @@     ,defaultSpaceWidth     ,new     ,newForWidget+    ,newBoxedWidget     ) where  import qualified Graphics.UI.LUI.Widget as Widget+import qualified Graphics.UI.LUI.Widgets.Box as Box import qualified Graphics.UI.LUI.Widgets.Grid as Grid import qualified Graphics.UI.LUI.Widgets.TextView as TextView import qualified Graphics.UI.LUI.Widgets.Unfocusable as Unfocusable@@ -68,3 +70,12 @@     let handlers = fromMaybe Map.empty . widgetGetKeymap $ widget model     in new defaultKeysColor defaultDescColor defaultSpaceWidth            keysFont descFont handlers model++newBoxedWidget :: Box.Orientation -> Int -> Font -> Font -> Widget model -> Widget model+newBoxedWidget orientation space keysFont descFont widget = box+    where+        box = Box.new orientation items . reader . Box.Mutable $ 0+        items = [Box.Item widget 0.5+                ,Box.Item (Space.newWH space space) 0+                ,Box.Item keysTable 0]+        keysTable = newForWidget keysFont descFont box

@@ -6,17 +6,19 @@  import qualified Graphics.UI.LUI.Widget as Widget import Graphics.UI.LUI.Widget(Widget, WidgetFuncs(..))-import Graphics.UI.LUI.Draw(Size)+import Graphics.UI.HaskGame(Size) import Graphics.UI.HaskGame.Vector2(Vector2(..)) +import Data.Monoid(mempty)+ new :: Size -> Widget model new size =     const $     WidgetFuncs     {       widgetGetKeymap = Nothing-    , widgetDraw = \_ -> return size-    , widgetSize = \_ -> return size+    , widgetImage = const mempty+    , widgetSize = const size     }  newWH :: Int -> Int -> Widget model

@@ -18,7 +18,7 @@ where  import qualified Graphics.UI.LUI.Widget as Widget-import qualified Graphics.UI.LUI.Draw as Draw+import qualified Graphics.UI.LUI.Image as Image import qualified Graphics.UI.LUI.Widgets.FocusDelegator as FocusDelegator import Graphics.UI.LUI.Widget(WidgetFuncs(..)) @@ -36,6 +36,7 @@  import qualified Data.Map as Map import Data.Map((!))+import Data.Monoid(mconcat) import Control.Arrow(first, second)  type Cursor = Int@@ -141,22 +142,24 @@   let mutable@(Mutable text cursor) = model ^. acc   in WidgetFuncs   {-    widgetDraw = \drawInfo -> do-    -    if Widget.diHasFocus drawInfo-      then do-        textSize <- Draw.computeToDraw . Draw.textSize font $ text-        Vector2 w h <- Draw.computeToDraw . Draw.textSize font $ take cursor text-        let cursorSize = Vector2 cursorWidth h+    widgetImage = \drawInfo ->+      if Widget.diHasFocus drawInfo+      then+        let textSize = Image.textSize font text+            Vector2 w h = Image.textSize font $ take cursor text+            cursorSize = Vector2 cursorWidth h             cursorPos = Vector2 w 0-        Draw.rect bgColor textSize-        Draw.text textColor font text-        Draw.move cursorPos $ Draw.rect cursorColor cursorSize-        return textSize+        in+          mconcat+          [+           Image.rect bgColor textSize+          ,Image.text textColor font text+          ,Image.move cursorPos $ Image.rect cursorColor cursorSize+          ]       else-        Draw.text textColor font text+        Image.text textColor font text -  , widgetSize = \_ -> Draw.textSize font text+  , widgetSize = const $ Image.textSize font text    , widgetGetKeymap =     let applyToModel newMutable = acc `write` newMutable $ model

@@ -5,7 +5,7 @@ where  import qualified Graphics.UI.LUI.Widget as Widget-import qualified Graphics.UI.LUI.Draw as Draw+import qualified Graphics.UI.LUI.Image as Image import Graphics.UI.LUI.Widget(Widget, WidgetFuncs(..))  import Graphics.UI.HaskGame.Font(Font)@@ -16,7 +16,7 @@     const $     WidgetFuncs     {-      widgetDraw = \_ -> Draw.text textColor textSize text-    , widgetSize = \_ -> Draw.textSize textSize text+      widgetImage = const $ Image.text textColor textSize text+    , widgetSize = const $ Image.textSize textSize text     , widgetGetKeymap = Nothing     }

@@ -16,6 +16,6 @@     in WidgetFuncs     {       widgetSize = \_ -> widgetSize childWidgetFuncs noFocusDrawInfo-    , widgetDraw = \_ -> widgetDraw childWidgetFuncs noFocusDrawInfo+    , widgetImage = \_ -> widgetImage childWidgetFuncs noFocusDrawInfo     , widgetGetKeymap = Nothing     }