minilight 0.1.1 → 0.2.0

raw patch · 22 files changed

+762/−458 lines, 22 filesdep +uuidPVP ok

version bump matches the API change (PVP)

Dependencies added: uuid

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +19/−0
• examples/boids.hs +10/−4
• examples/button-counter.hs +9/−3
• minilight.cabal +12/−7
• src/Data/Component/AnimationLayer.hs +54/−0
• src/Data/Component/Basic.hs +122/−0
• src/Data/Component/Button.hs +69/−0
• src/Data/Component/Layer.hs +83/−0
• src/Data/Component/MessageEngine.hs +78/−0
• src/Data/Component/MessageLayer.hs +75/−0
• src/Data/Component/Resolver.hs +38/−0
• src/MiniLight.hs +94/−34
• src/MiniLight/Component.hs +1/−28
• src/MiniLight/Component/AnimationLayer.hs +0/−56
• src/MiniLight/Component/Button.hs +0/−67
• src/MiniLight/Component/Layer.hs +0/−85
• src/MiniLight/Component/MessageEngine.hs +0/−80
• src/MiniLight/Component/MessageLayer.hs +0/−77
• src/MiniLight/Component/Types.hs +40/−11
• src/MiniLight/Event.hs +34/−3
• src/MiniLight/Light.hs +18/−3

@@ -1,5 +1,11 @@ # Revision history for minilight +## 0.2 -- 2019-04-23++* New features:+    * Re-structured modules+    * Emit signals and signal handlers+ ## 0.1.1 -- 2019-04-14  * Fixes:

@@ -0,0 +1,19 @@+# minilight++[![CircleCI](https://circleci.com/gh/myuon/minilight.svg?style=svg)](https://circleci.com/gh/myuon/minilight) [![Hackage](http://img.shields.io/hackage/v/minilight.svg)](https://hackage.haskell.org/package/minilight) [![MIT license](http://img.shields.io/badge/license-MIT-blue.svg)](LICENSE)++A simple but powerful graphics library.++## Build++You first need to install [sdl2](https://www.libsdl.org/index.php) packages.++For Ubuntu 18.04:++```sh+~$ sudo apt install -y libsdl2-dev libsdl2-image-dev libsdl2-ttf-dev libsdl2-gfx-dev+```++## Examples++See [examples](https://github.com/myuon/minilight/tree/master/examples)

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+import Data.Component.Resolver import MiniLight import Control.Monad.State import qualified Data.Vector as V@@ -32,7 +33,7 @@ height :: Int height = 600 -mainloop :: StateT Game MiniLight ()+mainloop :: StateT Game MiniLoop () mainloop = do   Game { objects = objects, pic = pic } <- get @@ -109,10 +110,15 @@     )     vec -  runLightT id $ do+  runLightT $ do     pic <- triangleOutline (Vect.V4 100 100 100 255) (Vect.V2 10 20)      runMainloop-      (defConfig { appConfigFile = Nothing, additionalComponents = [] })+      id+      ( defConfig { appConfigFile        = Nothing+                  , additionalComponents = []+                  , componentResolver    = resolver+                  }+      )       (Game {objects = objs, pic = pic})-      (\_ -> execStateT mainloop)+      (execStateT mainloop)

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+import Data.Component.Resolver import MiniLight import qualified Data.Text as T import qualified SDL@@ -38,10 +39,15 @@  main :: IO () main = do-  runLightT id $ do+  runLightT $ do     button <- newComponent =<< new      runMainloop-      (defConfig { appConfigFile = Nothing, additionalComponents = [button] })+      id+      ( defConfig { appConfigFile        = Nothing+                  , additionalComponents = [button]+                  , componentResolver    = resolver+                  }+      )       ()-      (\_ -> return)+      return

@@ -3,7 +3,7 @@ --   For further documentation, see http://haskell.org/cabal/users-guide/  name:                minilight-version:             0.1.1+version:             0.2.0 synopsis:            A SDL2-based graphics library, batteries-included. description:   This package provides the wheel for a graphical application or a game.@@ -22,7 +22,9 @@ maintainer:          ioi.joi.koi.loi@gmail.com -- copyright: category:            Graphics-extra-source-files:  CHANGELOG.md+extra-source-files:+  CHANGELOG.md+  README.md  source-repository head   type:     git@@ -37,11 +39,13 @@     MiniLight.Component     MiniLight.Component.Types     MiniLight.Component.Loader-    MiniLight.Component.Layer-    MiniLight.Component.AnimationLayer-    MiniLight.Component.MessageEngine-    MiniLight.Component.MessageLayer-    MiniLight.Component.Button+    Data.Component.Basic+    Data.Component.Layer+    Data.Component.AnimationLayer+    Data.Component.MessageEngine+    Data.Component.MessageLayer+    Data.Component.Button+    Data.Component.Resolver   -- other-modules:   -- other-extensions:   build-depends:@@ -65,6 +69,7 @@     sdl2-image           >= 2.0.0 && < 2.1,     sdl2-ttf             >= 2.1.0 && < 2.2,     trifecta             >= 2 && < 2.1,+    uuid                 >= 1.3.12 && < 1.4,     yaml                 >= 0.11.0 && < 0.12,     mwc-random           >= 0.14.0 && < 0.15,   hs-source-dirs:      src

@@ -0,0 +1,54 @@+module Data.Component.AnimationLayer where++import Control.Monad.State+import Data.Aeson+import Linear+import Lens.Micro+import MiniLight+import qualified Data.Component.Layer as Layer+import qualified SDL+import qualified SDL.Vect as Vect++data AnimationLayer = AnimationLayer {+  layer :: Layer.Layer,+  counter :: Int,+  tileSize :: Vect.V2 Int,+  scaler :: Int,+  config :: Config+}++instance ComponentUnit AnimationLayer where+  update = execStateT $ do+    modify $ \c -> c { counter = (counter c + 1) }+    modify $ \c -> c { counter = if counter c >= (division (config c) ^._x * division (config c) ^. _y) * scaler c then 0 else counter c }++  figures comp = do+    let iv = V2 ((counter comp `div` scaler comp) `mod` division (config comp) ^. _x) ((counter comp `div` scaler comp) `div` division (config comp) ^. _x)+    return [+      clip (SDL.Rectangle (SDL.P (tileSize comp * iv)) (tileSize comp)) $ Layer.layer $ layer comp+      ]++data Config = Config {+  layerConf :: Layer.Config,+  division :: Vect.V2 Int+}++instance FromJSON Config where+  parseJSON = withObject "config" $ \v -> do+    conf <- parseJSON (Object v)+    division <- (\v -> Vect.V2 <$> v .: "x" <*> v .: "y") =<< v .: "division"++    return $ Config conf division++new :: Config -> MiniLight AnimationLayer+new conf = do+  layer <- Layer.new (layerConf conf)+  let size = getFigureSize (Layer.layer layer)++  return $ AnimationLayer+    { layer    = layer+    , counter  = 0+    , tileSize = div <$> size <*> division conf+    , scaler   = 25+    , config   = conf+    }

@@ -0,0 +1,122 @@+{-| The package provides the basics for all components in the library.++A component should have the followings (those can be omitted):++- position: @{x: int, y: int}@+- size: @{width: int, height: int}@+- color: @int[4]@+- font: @{family: string, bold: bool, italic: bool, size: int}@++-}+module Data.Component.Basic where++import Data.Aeson+import Data.Aeson.Types+import Data.Typeable+import Data.Word (Word8)+import qualified SDL+import qualified SDL.Vect as Vect+import qualified SDL.Font+import MiniLight++-- | Basic config type+data Config = Config {+  size :: Vect.V2 Int,+  position :: Vect.V2 Int,+  color :: Vect.V4 Word8,+  fontDesc :: FontDescriptor,+  fontSize :: Int+}++instance FromJSON Config where+  parseJSON = withObject "config" $ \v -> do+    sizeMaybe <- v .:? "size"+    size <- (\w -> maybe (return 0) w sizeMaybe) $ withObject "size" $ \v ->+      Vect.V2 <$> v .: "width" <*> v .: "height"++    positionMaybe <- v .:? "position"+    position <- (\w -> maybe (return 0) w positionMaybe) $ withObject "position" $ \v ->+      Vect.V2 <$> v .: "x" <*> v .: "y"++    color <- fmap (\[r,g,b,a] -> Vect.V4 r g b a) $ v .:? "color" .!= [255, 255, 255, 255]++    fontMaybe <- v .:? "font"+    (fontDesc, fontSize) <- (\w -> maybe (return (FontDescriptor "" (FontStyle False False), 0)) w fontMaybe) $ withObject "font" $ \v -> do+      family <- v .: "family"+      size <- v .: "size"+      bold <- v .:? "bold" .!= False+      italic <- v .:? "italic" .!= False++      return $ (FontDescriptor family (FontStyle bold italic), size)++    return $ Config size position color fontDesc fontSize++-- | Load a system font from 'Config' type.+loadFontFrom :: Config -> MiniLight SDL.Font.Font+loadFontFrom conf = loadFont (fontDesc conf) (fontSize conf)++-- | This wrapper function is useful when you write your component config parser.+wrapConfig+  :: (Config -> a -> Parser r) -> (Object -> Parser a) -> Value -> Parser r+wrapConfig f p = withObject "wrapConfig" $ \v -> do+  other <- p v+  conf  <- parseJSON (Object v)+  f conf other++-- | The rectangle region of the component.+areaRectangle :: Config -> SDL.Rectangle Int+areaRectangle conf = SDL.Rectangle (SDL.P (position conf)) (size conf)++-- | Basic signal type.+data Signal where+  MousePressed+    :: Vect.V2 Int  -- ^ The relative position of the mouse pointer+    -> Signal+  MouseReleased+    :: Vect.V2 Int  -- ^ The relative position of the mouse pointer+    -> Signal+  MouseOver+    :: Vect.V2 Int  -- ^ The relative position of the mouse pointer+    -> Signal+  deriving Typeable++instance EventType Signal++-- | This wrapper function is useful when you write your own 'onSignal' component.+wrapSignal+  :: ( HasLightEnv env+     , HasLoopEnv env+     , HasComponentEnv env+     , MonadIO m+     , ComponentUnit c+     )+  => (c -> Config)  -- ^ 'Config' getter+  -> (Event -> c -> LightT env m c)  -- ^ Custom @onSignal@ function+  -> (Event -> c -> LightT env m c)+wrapSignal getter f ev comp = do+  emitBasicSignal ev (getter comp)+  f               ev comp++-- | Basic signaling function.+emitBasicSignal+  :: (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m)+  => Event+  -> Config+  -> LightT env m ()+emitBasicSignal (RawEvent (SDL.Event _ (SDL.MouseMotionEvent (SDL.MouseMotionEventData _ _ _ (SDL.P pos) _)))) conf+  | contains (areaRectangle conf) (fmap fromEnum pos)+  = emit $ MouseOver $ fmap fromEnum pos - position conf+emitBasicSignal (RawEvent (SDL.Event _ (SDL.MouseButtonEvent (SDL.MouseButtonEventData _ state _ _ _ (SDL.P pos))))) conf+  | contains (areaRectangle conf) (fmap fromEnum pos)+  = emit+    $ ( case state of+        SDL.Pressed  -> MousePressed+        SDL.Released -> MouseReleased+      )+    $ fmap fromEnum pos+    - position conf+emitBasicSignal _ _ = return ()++contains :: (Ord a, Num a) => SDL.Rectangle a -> Vect.V2 a -> Bool+contains (SDL.Rectangle (Vect.P (Vect.V2 x y)) (Vect.V2 w h)) (Vect.V2 px py) =+  x <= px && px <= x + w && y <= py && py <= y + h

@@ -0,0 +1,69 @@+module Data.Component.Button where++import Data.Aeson+import qualified Data.Text as T+import Data.Typeable+import Data.Word (Word8)+import MiniLight+import qualified SDL+import qualified SDL.Font+import qualified SDL.Vect as Vect++data Button = Button {+  font :: SDL.Font.Font,+  config :: Config+}++data ButtonEvent = Click+  deriving Typeable++instance EventType ButtonEvent++instance ComponentUnit Button where+  update = return++  figures comp = do+    textTexture <- liftMiniLight $ text (font comp) (color (config comp)) $ label (config comp)+    base <- liftMiniLight $ rectangleFilled (Vect.V4 200 200 200 255) (getFigureSize textTexture)++    return [+      base,+      textTexture+      ]++  useCache _ _ = True++  onSignal (RawEvent (SDL.Event _ (SDL.MouseButtonEvent (SDL.MouseButtonEventData _ SDL.Released _ _ _ _)))) comp = do+    emit Click+    return comp+  onSignal _ comp = return comp++  beforeClearCache _ figs = mapM_ freeFigure figs++data Config = Config {+  size :: Vect.V2 Int,+  label :: T.Text,+  color :: Vect.V4 Word8,+  fontConf :: FontDescriptor,+  fontSize :: Int+}++instance FromJSON Config where+  parseJSON = withObject "config" $ \v -> do+    size <- withObject "font" (\v -> Vect.V2 <$> v .: "width" <*> v .: "height") =<< v .: "size"+    label <- v .: "label"+    [r,g,b,a] <- v .:? "color" .!= [255, 255, 255, 255]+    (fontConf, fontSize) <- (v .: "font" >>=) $ withObject "font" $ \v -> do+      family <- v .: "family"+      size <- v .: "size"+      bold <- v .:? "bold" .!= False+      italic <- v .:? "italic" .!= False++      return $ (FontDescriptor family (FontStyle bold italic), size)++    return $ Config size label (Vect.V4 r g b a) fontConf fontSize++new :: Config -> MiniLight Button+new conf = do+  font <- loadFont (fontConf conf) (fontSize conf)+  return $ Button {font = font, config = conf}

@@ -0,0 +1,83 @@+module Data.Component.Layer where++import Control.Monad+import Data.Aeson+import Lens.Micro+import Lens.Micro.Mtl+import Linear+import MiniLight+import qualified SDL+import qualified SDL.Vect as Vect++data Layer = Layer {+  layer :: Figure+}++instance ComponentUnit Layer where+  figures comp = return [layer comp]++data Config = Config {+  image :: FilePath,+  size :: Vect.V2 Int,+  position :: Vect.V2 Int+}++instance FromJSON Config where+  parseJSON = withObject "config" $ \v -> do+    image <- v .: "image"+    size <- withObject "size" (\v -> Vect.V2 <$> v .: "width" <*> v .: "height") =<< v .: "size"++    positionMaybe <- v .:? "position"+    position <- maybe (return 0) (withObject "position" (\v -> Vect.V2 <$> v .: "x" <*> v .: "y")) positionMaybe++    return $ Config image size position++new :: Config -> MiniLight Layer+new conf = do+  pic <- picture (image conf)+  return $ Layer {layer = pic}++newNineTile :: Config -> MiniLight Layer+newNineTile conf = do+  pic <- picture $ image conf+  let siz     = fmap toEnum $ size conf+  let tex     = texture pic+  let texSize = fmap toEnum $ getFigureSize pic++  tinfo    <- SDL.queryTexture tex+  renderer <- view rendererL++  target   <- SDL.createTexture renderer+                                (SDL.texturePixelFormat tinfo)+                                SDL.TextureAccessTarget+                                siz+  SDL.rendererRenderTarget renderer SDL.$= Just target+  SDL.textureBlendMode target SDL.$= SDL.BlendAlphaBlend++  let tileSize = fmap (`div` 3) texSize++  forM_ [0 .. 2] $ \ix -> forM_ [0 .. 2] $ \iy -> do+    let targetSize = V2+          (if ix == 1 then siz ^. _x - 2 * tileSize ^. _x else tileSize ^. _x)+          (if iy == 1 then siz ^. _y - 2 * tileSize ^. _y else tileSize ^. _y)+    let targetLoc = V2+          ( if ix == 0+            then 0+            else if ix == 1 then tileSize ^. _x else siz ^. _x - tileSize ^. _x+          )+          ( if iy == 0+            then 0+            else if iy == 1 then tileSize ^. _y else siz ^. _y - tileSize ^. _y+          )++    SDL.copy+      renderer+      tex+      (Just $ SDL.Rectangle (SDL.P (tileSize * Vect.V2 ix iy)) tileSize)+      (Just $ SDL.Rectangle (SDL.P targetLoc) targetSize)++  SDL.rendererRenderTarget renderer SDL.$= Nothing++  tex <- fromTexture target+  return $ Layer {layer = tex}+

@@ -0,0 +1,78 @@+module Data.Component.MessageEngine where++import Control.Monad.State+import Data.Aeson+import qualified Data.Text as T+import Data.Word (Word8)+import Lens.Micro.Mtl+import MiniLight+import qualified SDL+import qualified SDL.Font+import qualified SDL.Vect as Vect++data MessageEngine = MessageEngine {+  font :: SDL.Font.Font,+  counter :: Int,+  rendered :: Int,+  textTexture :: Figure,+  finished :: Bool,+  config :: Config+}++instance ComponentUnit MessageEngine where+  update = execStateT $ do+    comp <- get++    unless (finished comp) $ do+      when (counter comp `mod` 10 == 0) $ do+        id %= (\c -> c { rendered = rendered c + 1 })++        comp <- get+        when (rendered comp == T.length (messages (config comp))) $ do+          id %= (\c -> c { finished = True })++      id %= (\c -> c { counter = counter c + 1 })++  figures comp = do+    (w, h) <- SDL.Font.size (font comp) (T.take (rendered comp) $ messages (config comp))++    return [+      clip (SDL.Rectangle 0 (Vect.V2 w h)) $ textTexture comp+      ]++data Config = Config {+  messages :: T.Text,+  static :: Bool,+  color :: Vect.V4 Word8,+  fontConf :: FontDescriptor,+  fontSize :: Int+}++instance FromJSON Config where+  parseJSON = withObject "config" $ \v -> do+    messages <- v .: "messages"+    static <- v .:? "static" .!= False+    [r,g,b,a] <- v .:? "color" .!= [255, 255, 255, 255]+    (fontConf, size) <- (v .: "font" >>=) $ withObject "font" $ \v -> do+      family <- v .: "family"+      size <- v .: "size"+      bold <- v .:? "bold" .!= False+      italic <- v .:? "italic" .!= False++      return $ (FontDescriptor family (FontStyle bold italic), size)++    return $ Config messages static (Vect.V4 r g b a) fontConf size++new :: Config -> MiniLight MessageEngine+new conf = do+  font        <- loadFont (fontConf conf) (fontSize conf)+  textTexture <- text font (color conf) $ messages conf++  return $ MessageEngine+    { font        = font+    , counter     = 0+    , rendered    = if static conf then T.length (messages conf) else 0+    , textTexture = textTexture+    , finished    = static conf+    , config      = conf+    }

@@ -0,0 +1,75 @@+module Data.Component.MessageLayer where++import Control.Monad.State+import Data.Aeson+import Lens.Micro+import Lens.Micro.Mtl+import Linear+import MiniLight+import qualified Data.Component.Layer as CLayer+import qualified Data.Component.AnimationLayer as CAnim+import qualified Data.Component.MessageEngine as CME+import qualified SDL.Vect as Vect++data MessageLayer = MessageLayer {+  messageEngine :: CME.MessageEngine,+  layer :: CLayer.Layer,+  cursor :: CAnim.AnimationLayer,+  config :: Config+}++engineL :: Lens' MessageLayer CME.MessageEngine+engineL = lens messageEngine (\s a -> s { messageEngine = a })++cursorL :: Lens' MessageLayer CAnim.AnimationLayer+cursorL = lens cursor (\s a -> s { cursor = a })++instance ComponentUnit MessageLayer where+  update = execStateT $ do+    zoom engineL $ do+      c <- use id+      id <~ lift (update c)++    zoom cursorL $ do+      c <- use id+      id <~ lift (update c)++  figures comp = do+    baseLayer <- figures $ layer comp+    cursorLayer <- figures $ cursor comp+    textLayer <- figures $ messageEngine comp++    let cursorSize = div <$> CAnim.tileSize (cursor comp) <*> CAnim.division (CAnim.config (cursor comp))+    let windowSize = CLayer.size $ window $ config comp++    return+      $ map (translate (CLayer.position (window (config comp)))) $ baseLayer+      ++ map (translate (Vect.V2 20 10)) textLayer+      ++ map (translate (Vect.V2 ((windowSize ^. _x - cursorSize ^. _x) `div` 2) (windowSize ^. _y - cursorSize ^. _y))) cursorLayer++data Config = Config {+  engine :: CME.Config,+  window :: CLayer.Config,+  next :: CAnim.Config+}++instance FromJSON Config where+  parseJSON = withObject "config" $ \v -> do+    layerConf <- parseJSON =<< v .: "window"+    nextConf <- parseJSON =<< v .: "next"+    messageEngineConf <- parseJSON =<< v .: "engine"++    return $ Config messageEngineConf layerConf nextConf++new :: Config -> MiniLight MessageLayer+new conf = do+  engine <- CME.new (engine conf)+  layer  <- CLayer.newNineTile (window conf)+  cursor <- CAnim.new (next conf)++  return $ MessageLayer+    { messageEngine = engine+    , layer         = layer+    , cursor        = cursor+    , config        = conf+    }

@@ -0,0 +1,38 @@+{-| This module provides the default resolver for pre-defined components.+-}+module Data.Component.Resolver (+  resolver,+  foldResult,+) where++import qualified Data.Aeson as Aeson+import qualified Data.Text as T+import MiniLight+import qualified Data.Component.AnimationLayer as AnimationLayer+import qualified Data.Component.Button as Button+import qualified Data.Component.Layer as Layer+import qualified Data.Component.MessageEngine as MessageEngine+import qualified Data.Component.MessageLayer as MessageLayer++foldResult :: (String -> b) -> (a -> b) -> Aeson.Result a -> b+foldResult f g r = case r of+  Aeson.Error   err -> f err+  Aeson.Success a   -> g a++-- | Pre-defined resolver supports all components in this library.+resolver :: Resolver+resolver name props = case name of+  "animation-layer" -> newComponent+    =<< AnimationLayer.new (foldResult error id $ Aeson.fromJSON props)+  "button" ->+    newComponent =<< Button.new (foldResult error id $ Aeson.fromJSON props)+  "layer" ->+    newComponent =<< Layer.new (foldResult error id $ Aeson.fromJSON props)+  "message-engine" -> newComponent+    =<< MessageEngine.new (foldResult error id $ Aeson.fromJSON props)+  "message-layer" -> newComponent+    =<< MessageLayer.new (foldResult error id $ Aeson.fromJSON props)+  "tiled-layer" -> newComponent+    =<< Layer.newNineTile (foldResult error id $ Aeson.fromJSON props)+  _ -> error $ T.unpack $ "Component not defined: `" <> name <> "`"+

@@ -9,7 +9,8 @@   runLightT,   LoopConfig (..),   defConfig,-  LoopState (..),+  LoopEnv (..),+  MiniLoop,   runMainloop, ) where @@ -17,12 +18,14 @@ import Control.Monad.Catch import Control.Monad.Reader import qualified Data.Aeson as Aeson-import Data.Hashable (Hashable(..)) import Data.Foldable (foldlM)+import Data.Hashable (Hashable(..)) import qualified Data.HashMap.Strict as HM+import Data.IORef import qualified Data.Text as T import qualified Data.Vector.Mutable as VM import Graphics.Text.TrueType+import Lens.Micro import Lens.Micro.Mtl import MiniLight.Component import MiniLight.Event@@ -35,18 +38,11 @@   hashWithSalt n sc = hashWithSalt n (SDL.unwrapScancode sc)  -- | Run a Light monad.-runLightT-  :: (HasLightEnv env, MonadIO m, MonadMask m)-  => (LightEnv -> env)  -- ^ construct @env@ value with initial 'LightEnv'-  -> LightT env m a-  -> m a-runLightT init prog = withSDL $ withWindow $ \window -> do+runLightT :: (MonadIO m, MonadMask m) => LightT LightEnv m a -> m a+runLightT prog = withSDL $ withWindow $ \window -> do   renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer   fc       <- loadFontCache-  runReaderT (runLightT' prog) $ init $ LightEnv-    { renderer  = renderer-    , fontCache = fc-    }+  runReaderT (runLightT' prog) $ LightEnv {renderer = renderer, fontCache = fc}  -- | Use 'defConfig' for a default setting. data LoopConfig = LoopConfig {@@ -56,47 +52,94 @@   additionalComponents :: [Component]  -- ^ The components here would be added during the initialization. } --- | Default configurations for the mainloop.+-- | Default configurations for the mainloop. You need to set @componentResolver@ if you use a component. defConfig :: LoopConfig defConfig = LoopConfig   { watchKeys            = Nothing   , appConfigFile        = Nothing-  , componentResolver    = defResolver+  , componentResolver    = \_ _ -> undefined   , additionalComponents = []   } --- | LoopState value would be passed to user side in a mainloop.-data LoopState = LoopState {-  keyStates :: HM.HashMap SDL.Scancode Int,  -- ^ Contains the number of frames that a specific keys are continuously pressing.-  events :: [SDL.Event],  -- ^ Occurred events since the last frame.-  components :: VM.IOVector Component  -- ^ Current components managed in a mainloop. Be careful to modify a component destructively.-}- fromList :: MonadIO m => [a] -> m (VM.IOVector a) fromList xs = liftIO $ do   vec <- VM.new $ length xs   forM_ (zip [0 ..] xs) $ uncurry (VM.write vec)   return vec +-- | LoopEnv value would be passed to user side in a mainloop.+data LoopEnv env = LoopState {+  env :: env,+  keyStates :: HM.HashMap SDL.Scancode Int,+  events :: IORef [Event],+  signalQueue :: IORef [Event],+  components :: VM.IOVector Component+}++-- | Lens to the env inside 'LoopState'+envL :: Lens' (LoopEnv env) env+envL = lens env (\e r -> e { env = r })++instance HasLightEnv env => HasLightEnv (LoopEnv env) where+  rendererL = envL . rendererL+  fontCacheL = envL . fontCacheL++instance HasLoopEnv (LoopEnv env) where+  keyStatesL = lens keyStates (\env r -> env { keyStates = r })+  eventsL = lens events (\env r -> env { events = r })+  signalQueueL = lens signalQueue (\env r -> env { signalQueue = r })++instance HasLightEnv env => HasLightEnv (T.Text, env) where+  rendererL = _2 . rendererL+  fontCacheL = _2 . fontCacheL++instance HasLoopEnv env => HasLoopEnv (T.Text, env) where+  keyStatesL = _2 . keyStatesL+  eventsL = _2 . eventsL+  signalQueueL = _2 . signalQueueL++instance HasComponentEnv (T.Text, env) where+  uidL = _1++-- | Type synonym to the minimal type of the mainloop+type MiniLoop = LightT (LoopEnv LightEnv) IO+ -- | Run a mainloop. -- In a mainloop, components and events are managed. -- -- Components in a mainloop: draw ~ update ~ (user-defined function) ~ event handling runMainloop-  :: (HasLightEnv env, MonadIO m, MonadMask m)-  => LoopConfig  -- ^ loop config+  :: ( HasLightEnv env+     , HasLightEnv loop+     , HasLoopEnv loop+     , MonadIO m+     , MonadMask m+     )+  => (LoopEnv env -> loop)  -- ^ LoopState conversion function (you can pass @id@, fixing @loop@ as @'LoopState' 'LightEnv'@)+  -> LoopConfig  -- ^ loop config   -> s  -- ^ initial state-  -> (LoopState -> s -> LightT env m s)  -- ^ a function called in every loop+  -> (s -> LightT loop m s)  -- ^ a function called in every loop   -> LightT env m ()-runMainloop conf initial loop = do+runMainloop conv conf initial loop = do   components <-     liftMiniLight $ fromList . (++ additionalComponents conf) =<< maybe       (return [])       (flip loadAppConfig (componentResolver conf))       (appConfigFile conf)+  events      <- liftIO $ newIORef []+  signalQueue <- liftIO $ newIORef [] -  go (LoopState {keyStates = HM.empty, events = [], components = components})-     initial+  env         <- view id+  go+    ( LoopState+      { keyStates   = HM.empty+      , events      = events+      , signalQueue = signalQueue+      , env         = env+      , components  = components+      }+    )+    initial  where   go loopState s = do     renderer <- view rendererL@@ -114,10 +157,11 @@      forM_ [0 .. VM.length (components loopState) - 1] $ \i -> do       comp  <- liftIO $ VM.read (components loopState) i-      comp' <- update comp+      comp' <- envLightT (\env -> (getUID comp, conv $ loopState { env = env }))+        $ update comp       liftIO $ VM.write (components loopState) i comp' -    s' <- loop loopState s+    s' <- envLightT (\env -> conv $ loopState { env = env }) $ loop s      liftIO $ SDL.present renderer @@ -125,11 +169,27 @@     events <- SDL.pollEvents     keys   <- SDL.getKeyboardState -    forM_ [0 .. VM.length (components loopState) - 1] $ \i -> do-      comp  <- liftIO $ VM.read (components loopState) i-      comp' <- foldlM (\comp ev -> onSignal (RawEvent ev) comp) comp events-      liftIO $ VM.write (components loopState) i comp'+    envLightT (\env -> conv $ loopState { env = env }) $ do+      evref <- view eventsL+      liftIO $ writeIORef evref $ map RawEvent events +      sigref  <- view signalQueueL+      signals <- liftIO $ readIORef sigref+      liftIO $ modifyIORef evref $ (++ signals)+      liftIO $ writeIORef sigref []++    envLightT (\env -> conv $ loopState { env = env }) $ do+      evref  <- view eventsL+      events <- liftIO $ readIORef evref++      forM_ [0 .. VM.length (components loopState) - 1] $ \i -> do+        comp  <- liftIO $ VM.read (components loopState) i+        comp' <- foldlM+          (\comp ev -> envLightT ((,) (getUID comp)) $ onSignal ev comp)+          comp+          events+        liftIO $ VM.write (components loopState) i comp'+     let       specifiedKeys = HM.mapWithKey         (\k v -> if keys k then v + 1 else 0)@@ -139,7 +199,7 @@             (watchKeys conf)         $ keyStates loopState         )-    let loopState' = loopState { keyStates = specifiedKeys, events = events }+    let loopState' = loopState { keyStates = specifiedKeys }     let quit = any           ( \event -> case SDL.eventPayload event of             SDL.WindowClosedEvent _ -> True

@@ -1,4 +1,4 @@-{-| The package provides configuration loader and pre-defined resolver.+{-| The package provides the configuration loader.  An configuration example: @@ -43,7 +43,6 @@   loadAppConfig,    Resolver,-  defResolver ) where  import qualified Data.Aeson as Aeson@@ -51,32 +50,6 @@ import MiniLight.Light import MiniLight.Component.Types import MiniLight.Component.Loader-import qualified MiniLight.Component.AnimationLayer as AnimationLayer-import qualified MiniLight.Component.Button as Button-import qualified MiniLight.Component.Layer as Layer-import qualified MiniLight.Component.MessageEngine as MessageEngine-import qualified MiniLight.Component.MessageLayer as MessageLayer -foldResult :: (String -> b) -> (a -> b) -> Aeson.Result a -> b-foldResult f g r = case r of-  Aeson.Error   err -> f err-  Aeson.Success a   -> g a- type Resolver = T.Text -> Aeson.Value -> MiniLight Component --- | Pre-defined resolver supports all components in this library.-defResolver :: Resolver-defResolver name props = case name of-  "animation-layer" -> newComponent-    =<< AnimationLayer.new (foldResult error id $ Aeson.fromJSON props)-  "button" ->-    newComponent =<< Button.new (foldResult error id $ Aeson.fromJSON props)-  "layer" ->-    newComponent =<< Layer.new (foldResult error id $ Aeson.fromJSON props)-  "message-engine" -> newComponent-    =<< MessageEngine.new (foldResult error id $ Aeson.fromJSON props)-  "message-layer" -> newComponent-    =<< MessageLayer.new (foldResult error id $ Aeson.fromJSON props)-  "tiled-layer" -> newComponent-    =<< Layer.newNineTile (foldResult error id $ Aeson.fromJSON props)-  _ -> error $ T.unpack $ "Component not defined: `" <> name <> "`"

@@ -1,56 +0,0 @@-module MiniLight.Component.AnimationLayer where--import Control.Monad.State-import Data.Aeson-import Linear-import Lens.Micro-import MiniLight.Figure-import MiniLight.Light-import qualified MiniLight.Component.Layer as Layer-import MiniLight.Component.Types-import qualified SDL-import qualified SDL.Vect as Vect--data AnimationLayer = AnimationLayer {-  layer :: Layer.Layer,-  counter :: Int,-  tileSize :: Vect.V2 Int,-  scaler :: Int,-  config :: Config-}--instance ComponentUnit AnimationLayer where-  update = execStateT $ do-    modify $ \c -> c { counter = (counter c + 1) }-    modify $ \c -> c { counter = if counter c >= (division (config c) ^._x * division (config c) ^. _y) * scaler c then 0 else counter c }--  figures comp = do-    let iv = V2 ((counter comp `div` scaler comp) `mod` division (config comp) ^. _x) ((counter comp `div` scaler comp) `div` division (config comp) ^. _x)-    return [-      clip (SDL.Rectangle (SDL.P (tileSize comp * iv)) (tileSize comp)) $ Layer.layer $ layer comp-      ]--data Config = Config {-  layerConf :: Layer.Config,-  division :: Vect.V2 Int-}--instance FromJSON Config where-  parseJSON = withObject "config" $ \v -> do-    conf <- parseJSON (Object v)-    division <- (\v -> Vect.V2 <$> v .: "x" <*> v .: "y") =<< v .: "division"--    return $ Config conf division--new :: Config -> MiniLight AnimationLayer-new conf = do-  layer <- Layer.new (layerConf conf)-  let size = getFigureSize (Layer.layer layer)--  return $ AnimationLayer-    { layer    = layer-    , counter  = 0-    , tileSize = div <$> size <*> division conf-    , scaler   = 25-    , config   = conf-    }

@@ -1,67 +0,0 @@-module MiniLight.Component.Button where--import Control.Monad.IO.Class-import Data.Aeson-import qualified Data.Text as T-import Data.Word (Word8)-import MiniLight.Component.Types-import MiniLight.Event-import MiniLight.Figure-import MiniLight.Light-import qualified SDL-import qualified SDL.Font-import qualified SDL.Vect as Vect--data Button = Button {-  font :: SDL.Font.Font,-  config :: Config-}--instance ComponentUnit Button where-  update = return--  figures comp = do-    textTexture <- liftMiniLight $ text (font comp) (color (config comp)) $ label (config comp)-    base <- liftMiniLight $ rectangleFilled (Vect.V4 200 200 200 255) (getFigureSize textTexture)--    return [-      base,-      textTexture-      ]--  useCache _ _ = True--  onSignal (RawEvent (SDL.Event _ (SDL.MouseButtonEvent (SDL.MouseButtonEventData _ SDL.Released _ _ _ _)))) comp = do-    liftIO $ print "hey!"-    return comp-  onSignal _ comp = return comp--  beforeClearCache _ figs = mapM_ freeFigure figs--data Config = Config {-  size :: Vect.V2 Int,-  label :: T.Text,-  color :: Vect.V4 Word8,-  fontConf :: FontDescriptor,-  fontSize :: Int-}--instance FromJSON Config where-  parseJSON = withObject "config" $ \v -> do-    size <- withObject "font" (\v -> Vect.V2 <$> v .: "width" <*> v .: "height") =<< v .: "size"-    label <- v .: "label"-    [r,g,b,a] <- v .:? "color" .!= [255, 255, 255, 255]-    (fontConf, fontSize) <- (v .: "font" >>=) $ withObject "font" $ \v -> do-      family <- v .: "family"-      size <- v .: "size"-      bold <- v .:? "bold" .!= False-      italic <- v .:? "italic" .!= False--      return $ (FontDescriptor family (FontStyle bold italic), size)--    return $ Config size label (Vect.V4 r g b a) fontConf fontSize--new :: Config -> MiniLight Button-new conf = do-  font <- loadFont (fontConf conf) (fontSize conf)-  return $ Button {font = font, config = conf}

@@ -1,85 +0,0 @@-module MiniLight.Component.Layer where--import Control.Monad-import Data.Aeson-import Lens.Micro-import Lens.Micro.Mtl-import Linear-import MiniLight.Component.Types-import MiniLight.Light-import MiniLight.Figure-import qualified SDL-import qualified SDL.Vect as Vect--data Layer = Layer {-  layer :: Figure-}--instance ComponentUnit Layer where-  figures comp = return [layer comp]--data Config = Config {-  image :: FilePath,-  size :: Vect.V2 Int,-  position :: Vect.V2 Int-}--instance FromJSON Config where-  parseJSON = withObject "config" $ \v -> do-    image <- v .: "image"-    size <- withObject "size" (\v -> Vect.V2 <$> v .: "width" <*> v .: "height") =<< v .: "size"--    positionMaybe <- v .:? "position"-    position <- maybe (return 0) (withObject "position" (\v -> Vect.V2 <$> v .: "x" <*> v .: "y")) positionMaybe--    return $ Config image size position--new :: Config -> MiniLight Layer-new conf = do-  pic <- picture (image conf)-  return $ Layer {layer = pic}--newNineTile :: Config -> MiniLight Layer-newNineTile conf = do-  pic <- picture $ image conf-  let siz     = fmap toEnum $ size conf-  let tex     = texture pic-  let texSize = fmap toEnum $ getFigureSize pic--  tinfo    <- SDL.queryTexture tex-  renderer <- view rendererL--  target   <- SDL.createTexture renderer-                                (SDL.texturePixelFormat tinfo)-                                SDL.TextureAccessTarget-                                siz-  SDL.rendererRenderTarget renderer SDL.$= Just target-  SDL.textureBlendMode target SDL.$= SDL.BlendAlphaBlend--  let tileSize = fmap (`div` 3) texSize--  forM_ [0 .. 2] $ \ix -> forM_ [0 .. 2] $ \iy -> do-    let targetSize = V2-          (if ix == 1 then siz ^. _x - 2 * tileSize ^. _x else tileSize ^. _x)-          (if iy == 1 then siz ^. _y - 2 * tileSize ^. _y else tileSize ^. _y)-    let targetLoc = V2-          ( if ix == 0-            then 0-            else if ix == 1 then tileSize ^. _x else siz ^. _x - tileSize ^. _x-          )-          ( if iy == 0-            then 0-            else if iy == 1 then tileSize ^. _y else siz ^. _y - tileSize ^. _y-          )--    SDL.copy-      renderer-      tex-      (Just $ SDL.Rectangle (SDL.P (tileSize * Vect.V2 ix iy)) tileSize)-      (Just $ SDL.Rectangle (SDL.P targetLoc) targetSize)--  SDL.rendererRenderTarget renderer SDL.$= Nothing--  tex <- fromTexture target-  return $ Layer {layer = tex}-

@@ -1,80 +0,0 @@-module MiniLight.Component.MessageEngine where--import Control.Monad.State-import Data.Aeson-import qualified Data.Text as T-import Data.Word (Word8)-import Lens.Micro.Mtl-import MiniLight.Component.Types-import MiniLight.Figure-import MiniLight.Light-import qualified SDL-import qualified SDL.Font-import qualified SDL.Vect as Vect--data MessageEngine = MessageEngine {-  font :: SDL.Font.Font,-  counter :: Int,-  rendered :: Int,-  textTexture :: Figure,-  finished :: Bool,-  config :: Config-}--instance ComponentUnit MessageEngine where-  update = execStateT $ do-    comp <- get--    unless (finished comp) $ do-      when (counter comp `mod` 10 == 0) $ do-        id %= (\c -> c { rendered = rendered c + 1 })--        comp <- get-        when (rendered comp == T.length (messages (config comp))) $ do-          id %= (\c -> c { finished = True })--      id %= (\c -> c { counter = counter c + 1 })--  figures comp = do-    (w, h) <- SDL.Font.size (font comp) (T.take (rendered comp) $ messages (config comp))--    return [-      clip (SDL.Rectangle 0 (Vect.V2 w h)) $ textTexture comp-      ]--data Config = Config {-  messages :: T.Text,-  static :: Bool,-  color :: Vect.V4 Word8,-  fontConf :: FontDescriptor,-  fontSize :: Int-}--instance FromJSON Config where-  parseJSON = withObject "config" $ \v -> do-    messages <- v .: "messages"-    static <- v .:? "static" .!= False-    [r,g,b,a] <- v .:? "color" .!= [255, 255, 255, 255]-    (fontConf, size) <- (v .: "font" >>=) $ withObject "font" $ \v -> do-      family <- v .: "family"-      size <- v .: "size"-      bold <- v .:? "bold" .!= False-      italic <- v .:? "italic" .!= False--      return $ (FontDescriptor family (FontStyle bold italic), size)--    return $ Config messages static (Vect.V4 r g b a) fontConf size--new :: Config -> MiniLight MessageEngine-new conf = do-  font        <- loadFont (fontConf conf) (fontSize conf)-  textTexture <- text font (color conf) $ messages conf--  return $ MessageEngine-    { font        = font-    , counter     = 0-    , rendered    = if static conf then T.length (messages conf) else 0-    , textTexture = textTexture-    , finished    = static conf-    , config      = conf-    }

@@ -1,77 +0,0 @@-module MiniLight.Component.MessageLayer where--import Control.Monad.State-import Data.Aeson-import Lens.Micro-import Lens.Micro.Mtl-import Linear-import MiniLight.Component.Types-import qualified MiniLight.Component.Layer as CLayer-import qualified MiniLight.Component.AnimationLayer as CAnim-import qualified MiniLight.Component.MessageEngine as CME-import MiniLight.Figure-import MiniLight.Light-import qualified SDL.Vect as Vect--data MessageLayer = MessageLayer {-  messageEngine :: CME.MessageEngine,-  layer :: CLayer.Layer,-  cursor :: CAnim.AnimationLayer,-  config :: Config-}--engineL :: Lens' MessageLayer CME.MessageEngine-engineL = lens messageEngine (\s a -> s { messageEngine = a })--cursorL :: Lens' MessageLayer CAnim.AnimationLayer-cursorL = lens cursor (\s a -> s { cursor = a })--instance ComponentUnit MessageLayer where-  update = execStateT $ do-    zoom engineL $ do-      c <- use id-      id <~ lift (update c)--    zoom cursorL $ do-      c <- use id-      id <~ lift (update c)--  figures comp = do-    baseLayer <- figures $ layer comp-    cursorLayer <- figures $ cursor comp-    textLayer <- figures $ messageEngine comp--    let cursorSize = div <$> CAnim.tileSize (cursor comp) <*> CAnim.division (CAnim.config (cursor comp))-    let windowSize = CLayer.size $ window $ config comp--    return-      $ map (translate (CLayer.position (window (config comp)))) $ baseLayer-      ++ map (translate (Vect.V2 20 10)) textLayer-      ++ map (translate (Vect.V2 ((windowSize ^. _x - cursorSize ^. _x) `div` 2) (windowSize ^. _y - cursorSize ^. _y))) cursorLayer--data Config = Config {-  engine :: CME.Config,-  window :: CLayer.Config,-  next :: CAnim.Config-}--instance FromJSON Config where-  parseJSON = withObject "config" $ \v -> do-    layerConf <- parseJSON =<< v .: "window"-    nextConf <- parseJSON =<< v .: "next"-    messageEngineConf <- parseJSON =<< v .: "engine"--    return $ Config messageEngineConf layerConf nextConf--new :: Config -> MiniLight MessageLayer-new conf = do-  engine <- CME.new (engine conf)-  layer  <- CLayer.newNineTile (window conf)-  cursor <- CAnim.new (next conf)--  return $ MessageLayer-    { messageEngine = engine-    , layer         = layer-    , cursor        = cursor-    , config        = conf-    }

@@ -1,25 +1,48 @@ {-# LANGUAGE ExistentialQuantification #-} module MiniLight.Component.Types (+  HasComponentEnv(..),+  emit,+   ComponentUnit(..),   Component,   newComponent,   getComponentSize,+  getUID,   propagate, ) where  import Control.Monad.Catch import Control.Monad.IO.Class import Data.IORef+import qualified Data.UUID+import qualified Data.UUID.V4+import qualified Data.Text as T+import Lens.Micro+import Lens.Micro.Mtl import MiniLight.Light import MiniLight.Event import MiniLight.Figure import qualified SDL +class HasComponentEnv env where+  -- | Lens to the unique id, which is provided for each component.+  uidL :: Lens' env T.Text++-- | Emit a signal, which will be catched at the next frame.+emit+  :: (HasLoopEnv env, HasComponentEnv env, MonadIO m, EventType et)+  => et+  -> LightT env m ()+emit et = do+  uid <- view uidL+  ref <- view signalQueueL+  liftIO $ modifyIORef' ref $ (signal uid et :)+ -- | CompoonentUnit typeclass provides a way to define a new component. -- Any 'ComponentUnit' instance can be embedded into 'Component' type. class ComponentUnit c where   -- | Updating a model.-  update :: (HasLightEnv env, MonadIO m, MonadMask m) => c -> LightT env m c+  update :: (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m, MonadMask m) => c -> LightT env m c   update = return    -- | Descirbes a view. The figures here would be cached. See also 'useCache' for the cache configuration.@@ -31,7 +54,7 @@   {-# INLINE draw #-}    -- | Event handlers-  onSignal :: (HasLightEnv env, MonadIO m, MonadMask m) => Event -> c -> LightT env m c+  onSignal :: (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m, MonadMask m) => Event -> c -> LightT env m c   onSignal _ = return    -- | Return @True@ if a cache stored in the previous frame should be used.@@ -50,6 +73,7 @@  -- | A wrapper for 'ComponentUnit' instances. data Component = forall c. ComponentUnit c => Component {+  uid :: T.Text,   component :: c,   prev :: c,   cache :: IORef [Figure]@@ -61,9 +85,10 @@   => c   -> LightT env m Component newComponent c = do+  uid  <- liftIO $ Data.UUID.toText <$> Data.UUID.V4.nextRandom   figs <- figures c   ref  <- liftIO $ newIORef figs-  return $ Component {component = c, prev = c, cache = ref}+  return $ Component {uid = uid, component = c, prev = c, cache = ref}  -- | Get the size of a component. getComponentSize@@ -74,26 +99,30 @@   figs <- figures comp   return $ foldl union (SDL.Rectangle (SDL.P 0) 0) $ map targetArea figs +-- | Get its unique id.+getUID :: Component -> T.Text+getUID (Component uid _ _ _) = uid+ -- | Clear the previous model cache and reflect the current model. propagate :: Component -> Component-propagate (Component comp _ cache) = Component comp comp cache+propagate (Component uid comp _ cache) = Component uid comp comp cache  instance ComponentUnit Component where-  update (Component comp prev cache) = do+  update (Component uid comp prev cache) = do     comp' <- update comp-    return $ Component comp' prev cache+    return $ Component uid comp' prev cache -  figures (Component comp _ _) = figures comp+  figures (Component _ comp _ _) = figures comp -  draw (Component comp prev ref) = liftMiniLight $ do+  draw (Component _ comp prev ref) = do     if useCache prev comp-      then renders =<< liftIO (readIORef ref)+      then liftMiniLight . renders =<< liftIO (readIORef ref)       else do         figs <- liftIO (readIORef ref)         beforeClearCache comp figs          figs <- figures comp-        renders figs+        liftMiniLight $ renders figs         liftIO $ writeIORef ref figs -  onSignal ev (Component comp prev cache) = fmap (\comp' -> Component comp' prev cache) $ onSignal ev comp+  onSignal ev (Component uid comp prev cache) = fmap (\comp' -> Component uid comp' prev cache) $ onSignal ev comp

@@ -1,12 +1,43 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} module MiniLight.Event (-  Event(..),+  Event (..),+  EventType,+  signal,+  asSignal, ) where  import qualified SDL import qualified Data.Text as T-import Language.Haskell.TH (Name)+import Data.Type.Equality+import Type.Reflection +-- | EventType says some type can be used as an event type.+class Typeable e => EventType e++-- | This type is same as 'Dynamic' from @Data.Dynamic@, but it requires 'EventType' contraint.+data Dynamic where+  Dynamic :: forall a. EventType a => TypeRep a -> a -> Dynamic++toDyn :: EventType a => a -> Dynamic+toDyn v = Dynamic typeRep v++fromDynamic :: forall a . (EventType a) => Dynamic -> Maybe a+fromDynamic (Dynamic t v) | Just HRefl <- t `eqTypeRep` rep = Just v+                          | otherwise                       = Nothing+  where rep = typeRep :: TypeRep a++-- | Event type representation data Event   = Never-  | ComponentEvent Name T.Text+  | Signal T.Text Dynamic   | RawEvent SDL.Event++signal :: EventType a => T.Text -> a -> Event+signal t v = Signal t (toDyn v)++asSignal :: EventType a => Event -> T.Text -> Maybe a+asSignal (Signal t1 v) t2 | t1 == t2 = fromDynamic v+asSignal _             _             = Nothing

@@ -1,8 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RoleAnnotations #-} module MiniLight.Light (-  MonadIO(..),-   HasLightEnv (..),   LightT (..),   LightEnv (..),@@ -11,11 +9,16 @@   envLightT,   mapLightT, +  HasLoopEnv (..),+   FontDescriptor(..),   FontStyle(..),   loadFontCache,   loadFont,-  withFont+  withFont,++  -- * Re-exports+  MonadIO(..), ) where  import Control.Monad.IO.Class@@ -23,9 +26,11 @@ import Control.Monad.Reader import Data.Hashable (Hashable(..)) import qualified Data.HashMap.Strict as HM+import Data.IORef import Graphics.Text.TrueType import Lens.Micro import Lens.Micro.Mtl+import MiniLight.Event import qualified SDL import qualified SDL.Font @@ -73,6 +78,16 @@ mapLightT :: (m a -> n a) -> LightT env m a -> LightT env n a mapLightT f m = LightT $ ReaderT $ f . runReaderT (runLightT' m) {-# INLINE mapLightT #-}++class HasLoopEnv env where+  -- | Contains the number of frames that a specific keys are continuously pressing.+  keyStatesL :: Lens' env (HM.HashMap SDL.Scancode Int)++  -- | Occurred events since the last frame.+  eventsL :: Lens' env (IORef [Event])++  -- | A queue storing the events occurred in this frame.+  signalQueueL :: Lens' env (IORef [Event])  loadFontCache :: MonadIO m => m FontMap loadFontCache = do