minilight 0.2.0 → 0.3.0

raw patch · 27 files changed

+1094/−387 lines, 27 filesdep +aeson-diffdep +casterdep +fsnotifydep −microlens-mtldep ~microlensdep ~vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson-diff, caster, fsnotify, hashtables, lens, transformers

Dependencies removed: microlens-mtl

Dependency ranges changed: microlens, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +67/−0
• examples/boids.hs +1/−2
• examples/button-counter.hs +3/−3
• minilight.cabal +20/−4
• src/Control/Monad/Caster.hs +37/−0
• src/Data/Component/AnimationLayer.hs +7/−7
• src/Data/Component/Basic.hs +6/−22
• src/Data/Component/Layer.hs +17/−19
• src/Data/Component/MessageEngine.hs +1/−1
• src/Data/Component/MessageLayer.hs +8/−7
• src/Data/Component/Resolver.hs +25/−19
• src/Data/Component/Selection.hs +71/−0
• src/Data/Config/Font.hs +32/−0
• src/Data/Registry.hs +38/−0
• src/Data/Registry/Class.hs +61/−0
• src/Data/Registry/HashTable.hs +49/−0
• src/Data/Vector/Mutable/PushBack.hs +93/−0
• src/MiniLight.hs +138/−117
• src/MiniLight/Component.hs +1/−9
• src/MiniLight/Component/Internal/Resolver.hs +129/−0
• src/MiniLight/Component/Internal/Types.hs +50/−0
• src/MiniLight/Component/Loader.hs +189/−130
• src/MiniLight/Component/Types.hs +5/−8
• src/MiniLight/Event.hs +2/−0
• src/MiniLight/Figure.hs +7/−8
• src/MiniLight/Light.hs +31/−31

@@ -1,5 +1,11 @@ # Revision history for minilight +## 0.3 -- 2019-05-05++* New features:+    * Hot Config Replacement+    * Stdout Logger+ ## 0.2 -- 2019-04-23  * New features:

@@ -4,6 +4,8 @@  A simple but powerful graphics library. +*NB: This library is fairly unstable and highly experimental.*+ ## Build  You first need to install [sdl2](https://www.libsdl.org/index.php) packages.@@ -13,6 +15,71 @@ ```sh ~$ sudo apt install -y libsdl2-dev libsdl2-image-dev libsdl2-ttf-dev libsdl2-gfx-dev ```++## Tutorial++Create a new project. Assume that you have the `resource` directory under the project root, which contains the resource stuff.++Here is an example, specifying `resources/app.yml` for the configuration file and `resources` for the watching directory (dynamic hot reloading).++```hs+import Control.Monad+import Data.Component.Resolver (resolver)+import MiniLight++main :: IO ()+main = runLightT $ do+  runMiniloop+    ( defConfig { appConfigFile        = Just "resources/app.yml"+                , hotConfigReplacement = Just "resources"+                , componentResolver    = resolver+                }+    )+    ()+    return+```++In `resources/app.yml`, you can write your application configuration.++```yaml+_vars:+  window:+    width: 800+    height: 600+app:+  - name: layer+    properties:+      image: resources/background.png+      position:+        x: 0+        y: 0+  - name: message-layer+    properties:+      window:+        image: resources/window-base.png+        position:+          x: 0+          y: ${${var:window.height} - ${ref:..size.height}}+        size:+          width: ${var:window.width}+          height: 150+      next:+        image: resources/text-pause.png+        division:+          x: 1+          y: 6+        interval: 40+      engine:+        messages: This is a message.+        color: [255,255,255,255]+        font:+          family: IPAGothic+          size: 22+```++For the configuration syntax, see [MiniLight.Component](https://hackage.haskell.org/package/minilight-0.2.0/docs/MiniLight-Component.html).++For the pre-defined components, see the modules under `Data.Component`.  ## Examples 

@@ -113,8 +113,7 @@   runLightT $ do     pic <- triangleOutline (Vect.V4 100 100 100 255) (Vect.V2 10 20) -    runMainloop-      id+    runMiniloop       ( defConfig { appConfigFile        = Nothing                   , additionalComponents = []                   , componentResolver    = resolver

@@ -40,10 +40,10 @@ main :: IO () main = do   runLightT $ do-    button <- newComponent =<< new+    uid    <- newUID+    button <- newComponent uid =<< new -    runMainloop-      id+    runMiniloop       ( defConfig { appConfigFile        = Nothing                   , additionalComponents = [button]                   , componentResolver    = resolver

@@ -3,7 +3,7 @@ --   For further documentation, see http://haskell.org/cabal/users-guide/  name:                minilight-version:             0.2.0+version:             0.3.0 synopsis:            A SDL2-based graphics library, batteries-included. description:   This package provides the wheel for a graphical application or a game.@@ -12,7 +12,7 @@   .   - Figure: convenient SDL texture, once created, it can be translated or rotated during rendering.   - Component: a reusable widget with event handlers, its figures can also be cached.-  - dynamic component loading: view components can be constructed by an external yaml file.+  - Hot Config Replacement: view components can be constructed by an external yaml file with live preview.   - built-in components: some common components are predefined. You can define a new component by yourself.  -- bug-reports:@@ -32,56 +32,71 @@  library   exposed-modules:+    Control.Monad.Caster+    Data.Vector.Mutable.PushBack+    Data.Registry+    Data.Registry.Class+    Data.Registry.HashTable     MiniLight     MiniLight.Figure     MiniLight.Light     MiniLight.Event     MiniLight.Component     MiniLight.Component.Types+    MiniLight.Component.Internal.Types+    MiniLight.Component.Internal.Resolver     MiniLight.Component.Loader+    Data.Config.Font     Data.Component.Basic     Data.Component.Layer     Data.Component.AnimationLayer     Data.Component.MessageEngine     Data.Component.MessageLayer     Data.Component.Button+    Data.Component.Selection     Data.Component.Resolver   -- other-modules:   -- other-extensions:   build-depends:+    aeson-diff           >= 1.1.0 && < 1.2,     FontyFruity          >= 0.5.3 && < 0.6,     base                 >= 4.12.0 && < 4.13,+    caster               >= 0.0.2.0 && < 0.1,     containers           >= 0.6.0 && < 0.7,     text                 >= 1.2.3 && < 1.3,     vector               >= 0.12.0 && < 0.13,     aeson                >= 1.4.2 && < 1.5,     scientific           >= 0.3.6 && < 0.4,     hashable             >= 1.2.7 && < 1.3,+    hashtables           >= 1.2.3 && < 1.3,     template-haskell     >= 2.14.0 && < 2.15,     unordered-containers >= 0.2.10 && < 0.3,     exceptions           >= 0.10.1 && < 0.11,     mtl                  >= 2.2.2 && < 2.3,+    lens                 >= 4.17 && < 4.18,     linear               >= 1.20.8 && < 1.21,-    microlens            >= 0.4.10 && < 0.5,-    microlens-mtl        >= 0.1.11 && < 0.2,     sdl2                 >= 2.4.1 && < 2.5,     sdl2-gfx             >= 0.2 && < 0.3,     sdl2-image           >= 2.0.0 && < 2.1,     sdl2-ttf             >= 2.1.0 && < 2.2,+    transformers         >= 0.5.6 && < 0.6,     trifecta             >= 2 && < 2.1,     uuid                 >= 1.3.12 && < 1.4,     yaml                 >= 0.11.0 && < 0.12,     mwc-random           >= 0.14.0 && < 0.15,+    fsnotify             >= 0.3.0 && < 0.4,   hs-source-dirs:      src   default-language:    Haskell2010   default-extensions:      FlexibleContexts     FlexibleInstances     GADTs+    LambdaCase     OverloadedStrings     MultiParamTypeClasses     RankNTypes     Strict+    TemplateHaskell   ghc-options: -Wall -Wno-name-shadowing  test-suite tests@@ -96,6 +111,7 @@     tasty,     tasty-hspec,     trifecta,+    vector,     yaml,   hs-source-dirs:      test   default-language:    Haskell2010

@@ -0,0 +1,37 @@+{-| A simple logger class for LightT monad -}+module Control.Monad.Caster (+  MonadLogger (..),+  ToBuilder (..),+  LogLevel (..),+  LogQueue,+  stdoutLogger,+) where++import Control.Monad.IO.Class+import Control.Concurrent+import System.Log.Caster as Caster++class MonadLogger m where+  getLogger :: MonadIO m => m LogQueue++  debug :: (MonadIO m, ToBuilder s) => s -> m ()+  debug s = getLogger >>= \g -> Caster.debug g s++  info :: (MonadIO m, ToBuilder s) => s -> m ()+  info s = getLogger >>= \g -> Caster.info g s++  warn :: (MonadIO m, ToBuilder s) => s -> m ()+  warn s = getLogger >>= \g -> Caster.warn g s++  err :: (MonadIO m, ToBuilder s) => s -> m ()+  err s = getLogger >>= \g -> Caster.err g s++stdoutLogger :: LogLevel -> IO LogQueue+stdoutLogger level = do+  chan <- newLogChan+  q    <- newLogQueue++  _    <- forkIO $ relayLog chan level terminalListener+  _    <- forkIO $ broadcastLog q chan++  return q

@@ -1,9 +1,9 @@ module Data.Component.AnimationLayer where +import Control.Lens import Control.Monad.State import Data.Aeson import Linear-import Lens.Micro import MiniLight import qualified Data.Component.Layer as Layer import qualified SDL@@ -13,32 +13,33 @@   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 }+    modify $ \c -> c { counter = if counter c >= (division (config c) ^._x * division (config c) ^. _y) * interval (config 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)+    let iv = V2 ((counter comp `div` interval (config comp)) `mod` division (config comp) ^. _x) ((counter comp `div` interval (config 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+  division :: Vect.V2 Int,+  interval :: Int }  instance FromJSON Config where   parseJSON = withObject "config" $ \v -> do     conf <- parseJSON (Object v)     division <- (\v -> Vect.V2 <$> v .: "x" <*> v .: "y") =<< v .: "division"+    interval <- v .:? "interval" .!= 30 -    return $ Config conf division+    return $ Config conf division interval  new :: Config -> MiniLight AnimationLayer new conf = do@@ -49,6 +50,5 @@     { layer    = layer     , counter  = 0     , tileSize = div <$> size <*> division conf-    , scaler   = 25     , config   = conf     }

@@ -13,19 +13,14 @@ 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+  position :: Vect.V2 Int }  instance FromJSON Config where@@ -38,22 +33,7 @@     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)+    return $ Config size position  -- | This wrapper function is useful when you write your component config parser. wrapConfig@@ -81,6 +61,10 @@   deriving Typeable  instance EventType Signal++-- | This automatically applies basic configuration such as: position.+wrapFigures :: Config -> [Figure] -> [Figure]+wrapFigures conf = map (translate (position conf))  -- | This wrapper function is useful when you write your own 'onSignal' component. wrapSignal

@@ -1,51 +1,49 @@ module Data.Component.Layer where +import Control.Lens 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+import qualified Data.Component.Basic as Basic  data Layer = Layer {-  layer :: Figure+  layer :: Figure,+  config :: Config }  instance ComponentUnit Layer where-  figures comp = return [layer comp]+  figures comp = return $ Basic.wrapFigures (basic $ config comp) [layer comp]  data Config = Config {-  image :: FilePath,-  size :: Vect.V2 Int,-  position :: Vect.V2 Int+  basic :: Basic.Config,+  image :: FilePath }  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+  parseJSON = Basic.wrapConfig (\b l -> return $ Config b l) $ \v ->+    v .: "image"  new :: Config -> MiniLight Layer new conf = do   pic <- picture (image conf)-  return $ Layer {layer = pic} +  return $ Layer+    { layer  = pic+    , config = conf { basic = (basic conf) { Basic.size = getFigureSize pic } }+    }+ newNineTile :: Config -> MiniLight Layer newNineTile conf = do   pic <- picture $ image conf-  let siz     = fmap toEnum $ size conf+  let siz     = fmap toEnum $ Basic.size $ basic conf   let tex     = texture pic   let texSize = fmap toEnum $ getFigureSize pic    tinfo    <- SDL.queryTexture tex-  renderer <- view rendererL+  renderer <- view _renderer    target   <- SDL.createTexture renderer                                 (SDL.texturePixelFormat tinfo)@@ -79,5 +77,5 @@   SDL.rendererRenderTarget renderer SDL.$= Nothing    tex <- fromTexture target-  return $ Layer {layer = tex}+  return $ Layer {layer = tex, config = conf} 

@@ -1,10 +1,10 @@ module Data.Component.MessageEngine where +import Control.Lens 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

@@ -1,11 +1,11 @@ module Data.Component.MessageLayer where +import Control.Lens import Control.Monad.State import Data.Aeson-import Lens.Micro-import Lens.Micro.Mtl import Linear import MiniLight+import qualified Data.Component.Basic as Basic import qualified Data.Component.Layer as CLayer import qualified Data.Component.AnimationLayer as CAnim import qualified Data.Component.MessageEngine as CME@@ -39,13 +39,14 @@     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+    let cursorSize = CAnim.tileSize (cursor comp)+    let windowSize = Basic.size $ CLayer.basic $ window $ config comp+    let position = Basic.position $ CLayer.basic $ 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+      $ baseLayer+      ++ map (translate (position + Vect.V2 20 10)) textLayer+      ++ map (translate (position + Vect.V2 ((windowSize ^. _x - cursorSize ^. _x) `div` 2) (windowSize ^. _y - cursorSize ^. _y))) cursorLayer  data Config = Config {   engine :: CME.Config,

@@ -5,7 +5,8 @@   foldResult, ) where -import qualified Data.Aeson as Aeson+import Control.Monad+import Data.Aeson import qualified Data.Text as T import MiniLight import qualified Data.Component.AnimationLayer as AnimationLayer@@ -13,26 +14,31 @@ import qualified Data.Component.Layer as Layer import qualified Data.Component.MessageEngine as MessageEngine import qualified Data.Component.MessageLayer as MessageLayer+import qualified Data.Component.Selection as Selection -foldResult :: (String -> b) -> (a -> b) -> Aeson.Result a -> b+foldResult :: (String -> b) -> (a -> b) -> Result a -> b foldResult f g r = case r of-  Aeson.Error   err -> f err-  Aeson.Success a   -> g a+  Error   err -> f err+  Success a   -> g a +resultM+  :: Result a+  -> (a -> MiniLight Component)+  -> MiniLight (Either String Component)+resultM r m = foldResult (return . Left) (fmap Right . m) r+ -- | 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 <> "`"-+resolver name uid props = case name of+  "animation-layer" ->+    resultM (fromJSON props) $ newComponent uid <=< AnimationLayer.new+  "button" -> resultM (fromJSON props) $ newComponent uid <=< Button.new+  "layer"  -> resultM (fromJSON props) $ newComponent uid <=< Layer.new+  "message-engine" ->+    resultM (fromJSON props) $ newComponent uid <=< MessageEngine.new+  "message-layer" ->+    resultM (fromJSON props) $ newComponent uid <=< MessageLayer.new+  "tiled-layer" ->+    resultM (fromJSON props) $ newComponent uid <=< Layer.newNineTile+  "selection" -> resultM (fromJSON props) $ newComponent uid <=< Selection.new+  _           -> return $ Left $ "Unsupported component: " ++ T.unpack name

@@ -0,0 +1,71 @@+module Data.Component.Selection where++import Control.Lens+import Control.Monad.State+import Data.Aeson hiding ((.=))+import qualified Data.Config.Font as Font+import qualified Data.Text as T+import qualified Data.Vector as V+import Linear+import MiniLight+import qualified SDL.Font+import qualified SDL.Vect as Vect+import qualified Data.Component.Basic as Basic+import qualified Data.Component.Layer as Layer++data Selection = Selection {+  layer :: Layer.Layer,+  font :: SDL.Font.Font,+  hover :: Maybe Int,+  conf :: Config+}++hoverL :: Lens' Selection (Maybe Int)+hoverL = lens hover (\env r -> env { hover = r })++instance ComponentUnit Selection where+  update = return++  figures comp = do+    let p = Vect.V2 15 10+    textTextures <- V.forM (V.indexed $ labels $ conf comp) $ \(i,label) -> liftMiniLight $ fmap (translate (p + Vect.V2 0 (i * 30))) $ text (font comp) (Font.color $ fontConfig $ conf comp) label+    base <- figures (layer comp)+    highlight <- liftMiniLight $ rectangleFilled (Vect.V4 240 240 240 40) $ _y .~ 30 $ Basic.size (basic (conf comp))++    return $ base+      ++ map (translate (Basic.position $ basic $ conf comp)) (translate (Vect.V2 0 (maybe 0 id (hover comp) * 30 + p ^. _y)) highlight+      : V.toList textTextures)++  useCache c1 c2 = hover c1 == hover c2++  onSignal = Basic.wrapSignal (basic . conf) $ \ev sel -> flip execStateT sel $ do+    uid <- view uidL++    case ev `asSignal` uid of+      Just (Basic.MouseOver pos) | (pos ^. _y) `div` 30 <= V.length (labels (conf sel)) - 1 -> do+        hoverL .= Just ((pos ^. _y) `div` 30)+      _ -> return ()++  -- OMG+  beforeClearCache _ figs = mapM_ freeFigure $ tail figs++data Config = Config {+  basic :: Basic.Config,+  labels :: V.Vector T.Text,+  fontConfig :: Font.Config,+  image :: FilePath+}++instance FromJSON Config where+  parseJSON = withObject "selection" $ \v ->+    Config+      <$> parseJSON (Object v)+      <*> v .:? "labels" .!= V.empty+      <*> parseJSON (Object v)+      <*> v .: "image"++new :: Config -> MiniLight Selection+new conf = do+  font  <- Font.loadFontFrom (fontConfig conf)+  layer <- Layer.newNineTile $ Layer.Config (basic conf) (image conf)+  return $ Selection {font = font, conf = conf, hover = Nothing, layer = layer}

@@ -0,0 +1,32 @@+module Data.Config.Font where++import Data.Aeson+import Data.Word (Word8)+import MiniLight+import qualified SDL.Font+import qualified SDL.Vect as Vect++data Config = Config {+  descriptor :: FontDescriptor,+  size :: Int,+  color :: Vect.V4 Word8+}++instance FromJSON Config where+  parseJSON = withObject "font" $ \v -> do+    fontMaybe <- v .:? "font"++    case fontMaybe of+      Nothing -> return $ Config (FontDescriptor "" (FontStyle False False)) 0 (Vect.V4 0 0 0 255)+      Just w -> flip (withObject "font") w $ \v -> do+        family <- v .: "family"+        size <- v .: "size"+        bold <- v .:? "bold" .!= False+        italic <- v .:? "italic" .!= False+        [r,g,b,a] <- v .:? "color" .!= [0, 0, 0, 255]++        return $ Config (FontDescriptor family (FontStyle bold italic)) size (Vect.V4 r g b a)++-- | Load a system font from 'Config' type.+loadFontFrom :: Config -> MiniLight SDL.Font.Font+loadFontFrom conf = loadFont (descriptor conf) (size conf)

@@ -0,0 +1,38 @@+{-| This module provides a registry for the specific type with the Text key.++This module is intended to be imported @qualified@, like:+@+import qualified Data.Registry as R+@+-}+module Data.Registry (+  module Data.Registry.Class,++  Registry(..),+  fromList,+  new,+) where++import Control.Monad.IO.Class+import qualified Data.Text as T+import Data.Registry.Class+import Data.Registry.HashTable++-- | The @Registry@ type can represents any 'IRegistry' instance.+data Registry v = forall reg. IRegistry reg => Registry (reg v)++instance IRegistry Registry where+  (!?) (Registry reg) t = (!?) reg t+  asVec (Registry reg) = asVec reg+  write (Registry reg) k v = write reg k v+  register (Registry reg) k v = register reg k v+  insert (Registry reg) i k v = insert reg i k v+  delete (Registry reg) k = delete reg k++-- | /O(n)/ Create a registry from a list. The current implementation uses a hashtable, defined in the module 'Data.Registry.HashTable'.+fromList :: MonadIO m => [(T.Text, v)] -> m (Registry v)+fromList xs = fmap Registry $ fromListImpl xs++-- | Create a new empty registry.+new :: MonadIO m => m (Registry v)+new = fromList []

@@ -0,0 +1,61 @@+module Data.Registry.Class where++import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe (isJust)+import qualified Data.Text as T+import qualified Data.Vector.Mutable as VM++-- | @IRegistry@ typeclass presents a registry interface.+-- The complexity /O(1)/ in the operations can be "amortized" complexity.+class IRegistry reg where+  -- | /O(1)/ Checking if the specified key exists+  has :: MonadIO m => reg v -> T.Text -> m Bool+  has reg k = fmap isJust $ reg !? k++  -- | /O(1)/ Indexing+  (!) :: MonadIO m => reg v -> T.Text -> m v+  reg ! k = fmap (\(Just a) -> a) $ reg !? k++  -- | /O(1)/ Safe indexing+  (!?) :: MonadIO m => reg v -> T.Text -> m (Maybe v)++  -- | /O(1)/ Update, raise an exception if the key does not exist.+  update :: MonadIO m => reg v -> T.Text -> (v -> m v) -> m ()+  update reg k f = reg ! k >>= \v -> f v >>= \v' -> write reg k v'++  -- | /O(1)/ Write, raise an exception if the key does not exist.+  write :: MonadIO m => reg v -> T.Text -> v -> m ()++  -- | /O(1)/ Adding a new value to the last position+  register :: MonadIO m => reg v -> T.Text -> v -> m ()++  -- | /O(n)/ Inserting a new value to the specified position (in the underlying vector)+  insert :: MonadIO m => reg v -> Int -> T.Text -> v -> m ()++  -- | /O(n)/ Deleting the specified value (this is a slow operation).+  delete :: MonadIO m => reg v -> T.Text -> m ()++  -- | /O(1)/ Get the underlying vector. Be careful: modifying the vector might cause a problem.+  asVec :: reg v -> VM.IOVector v++infixl 9 !+infixl 9 !?++-- | For-loop over the registry, ignoring the key order.+forV_ :: (MonadIO m, IRegistry reg) => reg v -> (v -> m ()) -> m ()+forV_ reg iter =+  let vec = asVec reg+  in  forM_ [0 .. VM.length vec - 1] $ \i -> liftIO (VM.read vec i) >>= iter++-- | For-loop over the registry with the index, ignoring the key order.+iforV_ :: (MonadIO m, IRegistry reg) => reg v -> (Int -> v -> m ()) -> m ()+iforV_ reg iter =+  let vec = asVec reg+  in  forM_ [0 .. VM.length vec - 1] $ \i -> liftIO (VM.read vec i) >>= iter i++-- | Modifying the item one by one, ignoring the key order.+modifyV_ :: (MonadIO m, IRegistry reg) => reg v -> (v -> m v) -> m ()+modifyV_ reg iter = iforV_ reg $ \i v -> do+  v' <- iter v+  liftIO $ VM.write (asVec reg) i v'

@@ -0,0 +1,49 @@+{-| Registry implementation using hashtable+-}+module Data.Registry.HashTable where++import Control.Monad.IO.Class+import qualified Data.HashTable.IO as H+import Data.Foldable (foldlM)+import Data.Maybe (fromJust)+import Data.Registry.Class+import qualified Data.Text as T+import qualified Data.Vector.Mutable.PushBack as VMP++data HashTableImpl k v = HashTableImpl (H.BasicHashTable k Int) (VMP.IOVector v)++instance IRegistry (HashTableImpl T.Text) where+  (!?) (HashTableImpl reg vec) k = liftIO $ do+    i <- H.lookup reg k+    maybe (return Nothing) (fmap Just . VMP.read vec) i++  write (HashTableImpl ht vec) k v = liftIO $ do+    i <- fmap fromJust $ liftIO $ H.lookup ht k+    liftIO $ VMP.write vec i v++  register (HashTableImpl ht vec) k v = liftIO $ do+    len <- VMP.safeLength vec+    VMP.push vec v+    H.insert ht k len++  delete (HashTableImpl ht vec) k = liftIO $ do+    Just i <- H.lookup ht k+    VMP.delete vec i+    H.delete ht k++  insert (HashTableImpl ht vec) i k v = liftIO $ do+    VMP.insert vec i v+    H.insert ht k i++  asVec (HashTableImpl _ vec) = VMP.asUnsafeIOVector vec++fromListImpl :: MonadIO m => [(T.Text, v)] -> m (HashTableImpl T.Text v)+fromListImpl xs =+  liftIO+    $   HashTableImpl+    <$> ( H.new >>= \h -> foldlM+          (\acc (i, k) -> H.insert acc k i >> return acc)+          h+          (zip [0 ..] $ map fst xs)+        )+    <*> (VMP.fromList $ map snd xs)

@@ -0,0 +1,93 @@+{-| This module provides a variant of the vector, equipped with @push_back@ operation.+IOVector here are supposed to be used in single thread situation.+-}+module Data.Vector.Mutable.PushBack where++import Prelude hiding (length, read)+import Control.Monad+import Data.IORef+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as VM+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Unboxed.Mutable as VUM+import System.IO.Unsafe++-- | @IOVector@ consists of (1) pointer to the underlying vector (2) length+-- While 'Data.Vector' has the underlying array itself, this type only has the pointer.+-- This means read/write should be slower than the original vector.+data IOVector a = IOVector !(IORef (VM.IOVector a)) !(VUM.IOVector Int)++-- Allocate (p + 10)-element vector, which might be more efficient than allocating just a small size of vector, like 1-element or 2-element.+new :: Int -> IO (IOVector a)+new p = new' (p + 10)+  where new' p = IOVector <$> (newIORef =<< VM.new p) <*> (VUM.replicate 1 0)++read :: IOVector a -> Int -> IO a+read (IOVector vref _) k = readIORef vref >>= \vec -> VM.read vec k++-- | Get the position of the last cell in the @IOVector@. This operation is not safe because of the 'unsafePerformIO'.+safeLength :: IOVector a -> IO Int+safeLength (IOVector _ uvec) = VUM.read uvec 0++length :: IOVector a -> Int+length pvec = unsafePerformIO $ safeLength pvec++safeCapacity :: IOVector a -> IO Int+safeCapacity (IOVector vref _) = fmap VM.length $ readIORef vref++-- | Get the capacity of the @IOVector@. This operation is not safe because of the 'unsafePerformIO'.+capacity :: IOVector a -> Int+capacity pvec = unsafePerformIO $ safeCapacity pvec++write :: IOVector a -> Int -> a -> IO ()+write (IOVector vref _) i v = do+  vec <- readIORef vref+  VM.write vec i v++-- | /O(n)/ Insert a value into any place. This is a slow operation.+insert+  :: IOVector a  -- ^ The vector should have positive (non-zero) length+  -> Int+  -> a+  -> IO ()+insert pvec@(IOVector _ uvec) i v = do+  len <- safeLength pvec++  read pvec (len - 1) >>= push pvec+  forM_ (reverse [i .. len - 2]) $ \j -> read pvec j >>= write pvec (j + 1)+  write pvec i v++-- | /O(n)/ This is a slow operation. This also throws an exception if the specified index does not exist.+delete :: IOVector a -> Int -> IO ()+delete pvec@(IOVector _ uvec) i = do+  len <- safeLength pvec+  forM_ [i + 1 .. len - 1] $ \j -> read pvec j >>= write pvec (j - 1)+  VUM.modify uvec (\x -> x - 1) 0++push :: IOVector a -> a -> IO ()+push pvec@(IOVector vref uvec) v = do+  vec <- readIORef vref+  len <- safeLength pvec+  cap <- safeCapacity pvec+  when (len == cap) $ do+    vec' <- VM.grow vec cap+    writeIORef vref vec'++  write      pvec len   v+  VUM.modify uvec (+ 1) 0++fromList :: [a] -> IO (IOVector a)+fromList xs = do+  vec  <- V.thaw $ V.fromList xs+  vec' <- VM.grow vec ((VM.length vec + 5) * 2)+  vref <- newIORef vec'+  uvec <- VU.thaw $ VU.fromList [VM.length vec]+  return $ IOVector vref uvec++asIOVector :: IOVector a -> IO (VM.IOVector a)+asIOVector pvec@(IOVector vref _) = do+  len <- safeLength pvec+  readIORef vref >>= \vec -> return (VM.slice 0 len vec)++asUnsafeIOVector :: IOVector a -> VM.IOVector a+asUnsafeIOVector pvec = unsafePerformIO $ asIOVector pvec

@@ -1,5 +1,6 @@ {-| MiniLight module exports all basic concepts and oprations except for concrete components. -}+{-# LANGUAGE FunctionalDependencies #-} module MiniLight (   module MiniLight.Light,   module MiniLight.Event,@@ -7,30 +8,34 @@   module MiniLight.Component,    runLightT,+  LoopState (..),   LoopConfig (..),   defConfig,-  LoopEnv (..),-  MiniLoop,   runMainloop,+  MiniLoop,+  runMiniloop, ) where -import Control.Concurrent (threadDelay)+import Control.Concurrent (threadDelay, forkIO)+import Control.Concurrent.MVar+import Control.Lens+import qualified Control.Monad.Caster as Caster import Control.Monad.Catch import Control.Monad.Reader-import qualified Data.Aeson as Aeson import Data.Foldable (foldlM) import Data.Hashable (Hashable(..)) import qualified Data.HashMap.Strict as HM+import Data.Maybe import Data.IORef+import qualified Data.Registry as R+import qualified Data.Vector as V 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 import MiniLight.Figure import MiniLight.Light+import qualified System.FSNotify as Notify import qualified SDL import qualified SDL.Font @@ -42,13 +47,24 @@ runLightT prog = withSDL $ withWindow $ \window -> do   renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer   fc       <- loadFontCache-  runReaderT (runLightT' prog) $ LightEnv {renderer = renderer, fontCache = fc}+  logger   <- liftIO $ Caster.stdoutLogger Caster.LogDebug+  runReaderT (runLightT' prog)+    $ LightEnv {renderer = renderer, fontCache = fc, logger = logger}+ where+  withSDL =+    bracket (SDL.initializeAll >> SDL.Font.initialize)+            (\_ -> SDL.Font.quit >> SDL.quit)+      . const +  withWindow =+    bracket (SDL.createWindow "window" SDL.defaultWindow) SDL.destroyWindow+ -- | Use 'defConfig' for a default setting. data LoopConfig = LoopConfig {   watchKeys :: Maybe [SDL.Scancode],  -- ^ Set @Nothing@ if all keys should be watched. See also 'LoopState'.   appConfigFile :: Maybe FilePath,  -- ^ Specify a yaml file which describes component settings. See 'MiniLight.Component' for the yaml syntax.-  componentResolver :: T.Text -> Aeson.Value -> MiniLight Component,  -- ^ Your custom mappings between a component name and its type.+  hotConfigReplacement :: Maybe FilePath,  -- ^ The directory path to be watched. If set, the config file modification will replace the component dynamically.+  componentResolver :: Resolver,  -- ^ Your custom mappings between a component name and its type.   additionalComponents :: [Component]  -- ^ The components here would be added during the initialization. } @@ -57,111 +73,115 @@ defConfig = LoopConfig   { watchKeys            = Nothing   , appConfigFile        = Nothing+  , hotConfigReplacement = Nothing   , componentResolver    = \_ _ -> undefined   , additionalComponents = []   } -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+-- | The state in the mainloop.+data LoopState = LoopState {+  light :: LightEnv,+  loop :: LoopEnv,+  loader :: LoaderEnv } --- | Lens to the env inside 'LoopState'-envL :: Lens' (LoopEnv env) env-envL = lens env (\e r -> e { env = r })+makeLensesWith classyRules_ ''LoopState -instance HasLightEnv env => HasLightEnv (LoopEnv env) where-  rendererL = envL . rendererL-  fontCacheL = envL . fontCacheL+-- | Type synonym to the minimal type of the mainloop+type MiniLoop = LightT LoopState IO -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+-- These instances are used in the internal computation.+instance HasLightEnv LoopState where+  lightEnv = _light . lightEnv -instance HasLoopEnv env => HasLoopEnv (T.Text, env) where-  keyStatesL = _2 . keyStatesL-  eventsL = _2 . eventsL-  signalQueueL = _2 . signalQueueL+instance HasLoopEnv LoopState where+  loopEnv = _loop . loopEnv +instance HasLoaderEnv LoopState where+  loaderEnv = _loader . loaderEnv+++instance HasLightEnv env' => HasLightEnv (env, env') where+  lightEnv = _2 . lightEnv++instance HasLoopEnv env' => HasLoopEnv (env, env') where+  loopEnv = _2 . loopEnv++instance HasLoaderEnv env' => HasLoaderEnv (env, env') where+  loaderEnv = _2 . loaderEnv++ instance HasComponentEnv (T.Text, env) where   uidL = _1 --- | Type synonym to the minimal type of the mainloop-type MiniLoop = LightT (LoopEnv LightEnv) IO +-- | Same as 'runMainloop' but fixing the type.+runMiniloop :: LoopConfig -> s -> (s -> MiniLoop s) -> MiniLight ()+runMiniloop = runMainloop LoopState+ -- | 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-     , HasLightEnv loop-     , HasLoopEnv loop+     , HasLightEnv env'+     , HasLoopEnv env'+     , HasLoaderEnv env'      , 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-  -> (s -> LightT loop m s)  -- ^ a function called in every loop+  => (env -> LoopEnv -> LoaderEnv -> env')  -- ^ Environment conversion+  -> LoopConfig  -- ^ Loop config+  -> s  -- ^ Initial state+  -> (s -> LightT env' m s)  -- ^ A function called in every loop   -> LightT env m ()-runMainloop conv conf initial loop = do-  components <--    liftMiniLight $ fromList . (++ additionalComponents conf) =<< maybe-      (return [])-      (flip loadAppConfig (componentResolver conf))-      (appConfigFile conf)-  events      <- liftIO $ newIORef []+runMainloop conv conf initial userloop = do+  events      <- liftIO $ newMVar []   signalQueue <- liftIO $ newIORef []+  reg         <- R.new+  conf        <- liftIO $ newIORef $ AppConfig V.empty V.empty -  env         <- view id-  go-    ( LoopState-      { keyStates   = HM.empty-      , events      = events-      , signalQueue = signalQueue-      , env         = env-      , components  = components-      }-    )+  run+    (LoopEnv {keyStates = HM.empty, events = events, signalQueue = signalQueue})+    (LoaderEnv {registry = reg, appConfig = conf})     initial  where-  go loopState s = do-    renderer <- view rendererL+  run loop loader s = do+    setup loop loader+    go loop loader s++  setup loop loader = envLightT (\env -> conv env loop loader) $ do+    case (hotConfigReplacement conf, appConfigFile conf) of+      (Just dir, Just confPath) -> do+        liftIO $ forkIO $ Notify.withManager $ \mgr -> do+          _ <- Notify.watchDir mgr dir (const True) $ \ev -> do+            modifyMVar_ (loop ^. _events) $ return . (NotifyEvent ev :)++          forever $ threadDelay 1000000++        loadAppConfig confPath (componentResolver conf)+      _ -> return ()++    forM_ (additionalComponents conf) $ \component -> do+      reg <- view _registry+      R.register reg (getUID component) component++  go loop loader s = do+    renderer <- view _renderer     liftIO $ SDL.rendererDrawColor renderer SDL.$= 255     liftIO $ SDL.clear renderer -    forM_ [0 .. VM.length (components loopState) - 1] $ \i -> do-      comp <- liftIO $ VM.read (components loopState) i-      draw comp+    R.forV_ (loader ^. _registry) $ \comp -> draw comp      -- state propagation-    forM_ [0 .. VM.length (components loopState) - 1] $ \i -> do-      comp <- liftIO $ VM.read (components loopState) i-      liftIO $ VM.write (components loopState) i (propagate comp)+    R.modifyV_ (loader ^. _registry) $ return . propagate -    forM_ [0 .. VM.length (components loopState) - 1] $ \i -> do-      comp  <- liftIO $ VM.read (components loopState) i-      comp' <- envLightT (\env -> (getUID comp, conv $ loopState { env = env }))-        $ update comp-      liftIO $ VM.write (components loopState) i comp'+    R.modifyV_ (loader ^. _registry) $ \comp ->+      envLightT (\env -> (getUID comp, conv env loop loader)) $ update comp -    s' <- envLightT (\env -> conv $ loopState { env = env }) $ loop s+    s' <- envLightT (\env -> conv env loop loader) $ userloop s      liftIO $ SDL.present renderer @@ -169,37 +189,50 @@     events <- SDL.pollEvents     keys   <- SDL.getKeyboardState -    envLightT (\env -> conv $ loopState { env = env }) $ do-      evref <- view eventsL-      liftIO $ writeIORef evref $ map RawEvent events--      sigref  <- view signalQueueL+    envLightT (\env -> conv env loop loader) $ do+      evref   <- view _events+      sigref  <- view _signalQueue       signals <- liftIO $ readIORef sigref-      liftIO $ modifyIORef evref $ (++ signals)+      liftIO+        $ modifyMVar_ evref+        $ return+        . (map RawEvent events ++)+        . (signals ++)       liftIO $ writeIORef sigref [] -    envLightT (\env -> conv $ loopState { env = env }) $ do-      evref  <- view eventsL-      events <- liftIO $ readIORef evref+    envLightT (\env -> conv env loop loader) $ do+      evref  <- view _events+      events <- liftIO $ modifyMVar evref (\a -> return ([], a)) -      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'+      R.modifyV_ (loader ^. _registry) $ \comp -> do+        foldlM (\comp ev -> envLightT ((,) (getUID comp)) $ onSignal ev comp)+               comp+               events -    let-      specifiedKeys = HM.mapWithKey-        (\k v -> if keys k then v + 1 else 0)-        ( maybe-            id-            (\specified m -> HM.fromList $ map (\s -> (s, m HM.! s)) specified)-            (watchKeys conf)-        $ keyStates loopState-        )-    let loopState' = loopState { keyStates = specifiedKeys }+      forM_+          ( catMaybes $ map+            ( \e -> case e of+              NotifyEvent ev -> Just ev+              _              -> Nothing+            )+            events+          )+        $ \ev -> patchAppConfig+            (fromJust $ appConfigFile conf)+            (componentResolver conf)++    let loop' =+          loop+            &  _keyStates+            %~ HM.mapWithKey (\k v -> if keys k then v + 1 else 0)+            .  maybe+                 id+                 ( \specified m -> HM.fromList $ map+                   (\s -> (s, if HM.member s m then m HM.! s else 0))+                   specified+                 )+                 (watchKeys conf)+     let quit = any           ( \event -> case SDL.eventPayload event of             SDL.WindowClosedEvent _ -> True@@ -208,16 +241,4 @@           )           events -    unless quit $ go loopState' s'------withSDL :: (MonadIO m, MonadMask m) => m a -> m a-withSDL =-  bracket (SDL.initializeAll >> SDL.Font.initialize)-          (\_ -> SDL.Font.quit >> SDL.quit)-    . const--withWindow :: (MonadIO m, MonadMask m) => (SDL.Window -> m a) -> m a-withWindow =-  bracket (SDL.createWindow "window" SDL.defaultWindow) SDL.destroyWindow+    unless quit $ go loop' loader s'

@@ -40,16 +40,8 @@ -} module MiniLight.Component (   module MiniLight.Component.Types,-  loadAppConfig,--  Resolver,+  module MiniLight.Component.Loader, ) where -import qualified Data.Aeson as Aeson-import qualified Data.Text as T-import MiniLight.Light import MiniLight.Component.Types import MiniLight.Component.Loader--type Resolver = T.Text -> Aeson.Value -> MiniLight Component-

@@ -0,0 +1,129 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+module MiniLight.Component.Internal.Resolver where++import Control.Applicative+import Data.Aeson hiding (Result)+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Scientific (Scientific, fromFloatDigits)+import qualified Data.Vector as V+import Text.Trifecta++data Expr+  = None+  | Ref T.Text  -- ^ reference syntax: ${ref:...}+  | Var T.Text  -- ^ variable syntax: ${var:...}+  | Op T.Text Expr Expr  -- ^ expr operator: +, -, *, /+  | Constant Value  -- ^ constants (string or number or null)+  deriving (Eq, Show)++parser :: Parser Expr+parser = try reference <|> try variable <|> (char '$' *> braces (number <|> expr))+ where+  expr      = chainl expr1 op1 None+  expr1     = chainl expr2 op2 None+  expr2     = parens expr <|> try reference <|> try variable <|> try number++  -- low precedence infixl operator group+  op1       = Op "+" <$ textSymbol "+" <|> Op "-" <$ textSymbol "-"++  -- high precedence infixl operator group+  op2       = Op "*" <$ textSymbol "*" <|> Op "/" <$ textSymbol "/"++  reference = do+    char '$'+    braces $ text "ref:" *> (fmap (Ref . T.pack) (many (letter <|> oneOf ".")))+  variable = do+    char '$'+    braces $ text "var:" *> (fmap (Var . T.pack) (many (letter <|> oneOf ".")))+  number = fmap (Constant . Number . either fromIntegral fromFloatDigits)+                integerOrDouble++data Context = Context {+  path :: V.Vector (Either Int T.Text),+  variables :: Object,+  target :: Value+}++getAt :: Value -> [Either Int T.Text] -> Value+getAt = go+ where+  go value        [] = value+  go (Object obj) (Right key:ps) | key `HM.member` obj = go (obj HM.! key) ps+  go (Array  arr) (Left  i  :ps) | 0 <= i && i < V.length arr = go (arr V.! i) ps+  go v (p:_) =+    error+      $  "TypeError: path `"+      <> show p+      <> "` is missing in `"+      <> show v+      <> "`"++normalize+  :: V.Vector (Either Int T.Text) -> [Either Int T.Text] -> [Either Int T.Text]+normalize path1 ts = V.toList path1' ++ dropWhile (\v -> v == Right "") ts+ where+  depth  = length $ takeWhile (\v -> v == Right "") ts+  path1' = V.take (V.length path1 - depth - 1) path1++pattern Arithmetic :: T.Text -> Scientific -> Scientific -> Expr+pattern Arithmetic op n1 n2 =+  Op op (Constant (Number n1)) (Constant (Number n2))++eval :: Context -> Expr -> Value+eval ctx = go+ where+  go None = ""+  go (Ref path') =+    getAt (target ctx) (normalize (path ctx) (convertPath path'))+  go (Var path') =+    getAt (Object (variables ctx)) (normalize V.empty (convertPath path'))+  go (binds -> Arithmetic "+" n1 n2) = Number (n1+n2)+  go (binds -> Arithmetic "-" n1 n2) = Number (n1-n2)+  go (binds -> Arithmetic "*" n1 n2) = Number (n1*n2)+  go (binds -> Arithmetic "/" n1 n2) = Number (n1/n2)+  go expr = error $ "Illegal expression: " ++ show expr++  binds (Op op e1 e2) = Op op (Constant (eval ctx e1)) (Constant (eval ctx e2))+  binds _ = undefined++convertPath :: T.Text -> [Either Int T.Text]+convertPath+  = map+      ( \t ->+        foldResult (\_ -> Right t) (Left . fromIntegral) $ parseText index t+      )+    . T.splitOn "."+    . (\t -> if T.length t > 0 && T.head t == '.' then T.tail t else t)+  where index = char '[' *> natural <* char ']'++convert :: Context -> T.Text -> Value+convert ctx t = foldResult (\_ -> String t) (eval ctx) $ parseText parser t++parseText :: Parser a -> T.Text -> Result a+parseText parser = parseByteString parser mempty . TE.encodeUtf8++resolve :: Value -> Value+resolve = \value -> go (Context V.empty HM.empty value) value+ where+  go ctx (Object obj)+    | "_vars" `HM.member` obj+    = let vars = obj HM.! "_vars"+      in  go+            ( ctx+              { variables = HM.union ((\(Object o) -> o) $ vars) (variables ctx)+              }+            )+            (Object (HM.delete "_vars" obj))+    | otherwise+    = Object $ HM.mapWithKey+      (\key -> go (ctx { path = V.snoc (path ctx) (Right key) }))+      obj+  go ctx (Array arr) =+    Array $ V.imap (\i -> go (ctx { path = V.snoc (path ctx) (Left i) })) arr+  go ctx (String t) = convert ctx t+  go _ (Number n) = Number n+  go _ (Bool   b) = Bool b+  go _ Null       = Null

@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveGeneric #-}+module MiniLight.Component.Internal.Types where++import Data.Aeson+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.UUID+import qualified Data.UUID.V4+import GHC.Generics+import MiniLight.Component.Types+import MiniLight.Light++data ComponentConfig = ComponentConfig {+  name :: T.Text,+  properties :: Value+} deriving (Eq, Show, Generic)++instance ToJSON ComponentConfig+instance FromJSON ComponentConfig++data AppConfig = AppConfig {+  app :: V.Vector ComponentConfig,+  uuid :: V.Vector T.Text+} deriving (Eq, Show)++instance FromJSON AppConfig where+  parseJSON = withObject "app" $ \v -> do+    app <- v .: "app"++    return $ AppConfig app V.empty++-- | The type for component resolver+type Resolver+  = T.Text  -- ^ Component Type+  -> T.Text  -- ^ UID+  -> Value  -- ^ Component Property+  -> MiniLight (Either String Component)++-- | Generate an unique id.+newUID :: MonadIO m => m T.Text+newUID = liftIO $ Data.UUID.toText <$> Data.UUID.V4.nextRandom++-- | Create a component with given resolver.+createComponentBy+  :: Resolver+  -> Maybe T.Text+  -> ComponentConfig+  -> MiniLight (Either String Component)+createComponentBy resolver uid config =+  maybe newUID return uid >>= \u -> resolver (name config) u (properties config)

@@ -1,158 +1,217 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ViewPatterns #-}-module MiniLight.Component.Loader where+module MiniLight.Component.Loader (+  module MiniLight.Component.Internal.Types, -import Control.Applicative-import Control.Monad.IO.Class-import Data.Aeson hiding (Result)-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE+  LoaderEnv (..),+  HasLoaderEnv (..),++  resolveConfig,+  loadAppConfig,+  patchAppConfig,+) where++import Control.Lens+import Control.Monad+import qualified Control.Monad.Caster as Caster+import Control.Monad.Catch+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import Data.Aeson+import qualified Data.Aeson.Diff as Diff+import Data.Aeson.Patch+import Data.Aeson.Pointer+import Data.IORef+import qualified Data.Registry as R import qualified Data.Vector as V-import Data.Scientific (Scientific, fromFloatDigits) import Data.Yaml (decodeFileEither)-import GHC.Generics import MiniLight.Light import MiniLight.Component.Types-import Text.Trifecta+import MiniLight.Component.Internal.Types+import MiniLight.Component.Internal.Resolver (resolve) -data ComponentConfig = ComponentConfig {-  name :: T.Text,-  properties :: Value-} deriving Generic+-- | The environment for config loader+data LoaderEnv = LoaderEnv {+  registry :: R.Registry Component,+  appConfig :: IORef AppConfig+} -instance FromJSON ComponentConfig+makeClassy_ ''LoaderEnv -data AppConfig = AppConfig {-  app :: [ComponentConfig]-} deriving Generic+toEither :: Result a -> Either String a+toEither (Error   s) = Left s+toEither (Success a) = Right a -instance FromJSON AppConfig+-- | Load an config file and return the resolved @AppConfig@.+resolveConfig :: MonadIO m => FilePath -> m (Either String AppConfig)+resolveConfig path =+  liftIO+    $   (toEither . fromJSON <=< fmap resolve)+    .   either (Left . show) Right+    <$> decodeFileEither path --- | Load an config file and construct components.+-- | Load an config file and set in the environment. Calling this function at once, this overrides all values in the environment.+-- This will generate an error log and skip the component if the configuration is invalid.+-- This function also assign unique IDs for each component, using 'assignUID'. loadAppConfig-  :: (HasLightEnv env, MonadIO m)+  :: (HasLightEnv env, HasLoaderEnv env, MonadIO m, MonadCatch m)   => FilePath  -- ^ Filepath to the yaml file.-  -> (T.Text -> Value -> LightT env m Component)  -- ^ Specify any resolver.-  -> LightT env m [Component]-loadAppConfig path mapper = do-  conf <- liftIO $ (\(Data.Aeson.Success a) -> a) . fromJSON . resolve . either (error . show) id <$> decodeFileEither path-  mapM (\conf -> mapper (name conf) (properties conf)) (app conf)+  -> Resolver  -- ^ Specify any resolver.+  -> LightT env m ()+loadAppConfig path mapper = fmap (maybe () id) $ runMaybeT $ do+  conf <- resolveConfig path >>= \case+    Left e -> do+      lift $ Caster.err e+      fail ""+    Right r -> return r -data Expr-  = None-  | Ref T.Text  -- ^ reference syntax: ${ref:...}-  | Var T.Text  -- ^ variable syntax: ${var:...}-  | Op T.Text Expr Expr  -- ^ expr operator: +, -, *, /-  | Constant Value  -- ^ constants (string or number or null)-  deriving (Eq, Show)+  confs <- lift $ fmap (V.mapMaybe id) $ V.forM (app conf) $ \conf -> do+    uid    <- newUID+    result <- liftMiniLight $ mapper (name conf) uid (properties conf) -parser :: Parser Expr-parser = try reference <|> try variable <|> (char '$' *> braces (number <|> expr))- where-  expr      = chainl expr1 op1 None-  expr1     = chainl expr2 op2 None-  expr2     = parens expr <|> try reference <|> try variable <|> try number+    case result of+      Left e -> do+        Caster.err e+        return Nothing+      Right component -> do+        reg <- view _registry+        R.register reg uid component -  -- low precedence infixl operator group-  op1       = Op "+" <$ textSymbol "+" <|> Op "-" <$ textSymbol "-"+        Caster.info+          $  "Component loaded: {name: "+          <> show (name conf)+          <> ", uid: "+          <> show uid+          <> "}" -  -- high precedence infixl operator group-  op2       = Op "*" <$ textSymbol "*" <|> Op "/" <$ textSymbol "/"+        return $ Just (uid, conf) -  reference = do-    char '$'-    braces $ text "ref:" *> (fmap (Ref . T.pack) (many (letter <|> oneOf ".")))-  variable = do-    char '$'-    braces $ text "var:" *> (fmap (Var . T.pack) (many (letter <|> oneOf ".")))-  number = fmap (Constant . Number . either fromIntegral fromFloatDigits)-                integerOrDouble+  ref <- view _appConfig+  liftIO $ writeIORef ref $ AppConfig (V.map snd confs) (V.map fst confs) -data Context = Context {-  path :: V.Vector (Either Int T.Text),-  variables :: Object,-  target :: Value-}+-- | Load the config file again and place the newly loaded components. This is used for HCR (hot component replacement).+-- Call 'loadAppConfig' first.+patchAppConfig+  :: (HasLightEnv env, HasLoaderEnv env, MonadIO m, MonadCatch m)+  => FilePath  -- ^ Filepath to the yaml file.+  -> Resolver  -- ^ Specify any resolver.+  -> LightT env m ()+patchAppConfig path resolver = fmap (maybe () id) $ runMaybeT $ do+  cref      <- view _appConfig+  appConfig <- liftIO $ readIORef cref -getAt :: Value -> [Either Int T.Text] -> Value-getAt = go- where-  go value        [] = value-  go (Object obj) (Right key:ps) | key `HM.member` obj = go (obj HM.! key) ps-  go (Array  arr) (Left  i  :ps) | 0 <= i && i < V.length arr = go (arr V.! i) ps-  go v (p:_) =-    error-      $  "TypeError: path `"-      <> show p-      <> "` is missing in `"-      <> show v-      <> "`"+  conf'     <- do+    mconf <- lift $ resolveConfig path -normalize-  :: V.Vector (Either Int T.Text) -> [Either Int T.Text] -> [Either Int T.Text]-normalize path1 ts = V.toList path1' ++ dropWhile (\v -> v == Right "") ts- where-  depth  = length $ takeWhile (\v -> v == Right "") ts-  path1' = V.take (V.length path1 - depth - 1) path1+    case mconf of+      Left e -> do+        lift $ Caster.err e+        fail ""+      Right r -> return r -pattern Arithmetic :: T.Text -> Scientific -> Scientific -> Expr-pattern Arithmetic op n1 n2 =-  Op op (Constant (Number n1)) (Constant (Number n2))+  lift+    $ forM_+        ( Diff.patchOperations+        $ Diff.diff (toJSON $ app appConfig) (toJSON $ app conf')+        )+    $ \op -> fmap (maybe () id) $ runMaybeT $ do+        lift $ Caster.debug $ "CMR detected: " <> show op -eval :: Context -> Expr -> Value-eval ctx = go+        case op of+          Add (Pointer [AKey n]) v      -> create n v+          Rem (Pointer [AKey n])        -> remove n+          Rep (Pointer [AKey n     ]) v -> modify n (Rep (Pointer []) v)+          Rep (Pointer (AKey n:path)) v -> modify n (Rep (Pointer path) v)+          Add (Pointer (AKey n:path)) v -> modify n (Add (Pointer path) v)+          Rem (Pointer (AKey n:path))   -> modify n (Rem (Pointer path))+          _ ->+            lift+              $  Caster.warn+              $  "CMR does not support the operation yet: "+              <> show op  where-  go None = ""-  go (Ref path') =-    getAt (target ctx) (normalize (path ctx) (convertPath path'))-  go (Var path') =-    getAt (Object (variables ctx)) (normalize V.empty (convertPath path'))-  go (binds -> Arithmetic "+" n1 n2) = Number (n1+n2)-  go (binds -> Arithmetic "-" n1 n2) = Number (n1-n2)-  go (binds -> Arithmetic "*" n1 n2) = Number (n1*n2)-  go (binds -> Arithmetic "/" n1 n2) = Number (n1/n2)-  go expr = error $ "Illegal expression: " ++ show expr+  create n v = do+    cref     <- view _appConfig+    compConf <- case fromJSON v of+      Success a   -> return a+      Error   err -> do+        lift $ Caster.err err+        fail "" -  binds (Op op e1 e2) = Op op (Constant (eval ctx e1)) (Constant (eval ctx e2))-  binds _ = undefined+    newID     <- lift newUID+    component <- do+      result <- lift $ liftMiniLight $ createComponentBy resolver+                                                         (Just newID)+                                                         compConf -convertPath :: T.Text -> [Either Int T.Text]-convertPath-  = map-      ( \t ->-        foldResult (\_ -> Right t) (Left . fromIntegral) $ parseText index t-      )-    . T.splitOn "."-    . (\t -> if T.length t > 0 && T.head t == '.' then T.tail t else t)-  where index = char '[' *> natural <* char ']'+      case result of+        Left err -> do+          lift $ Caster.err $ "Failed to resolve: " <> err+          fail ""+        Right c -> return c -convert :: Context -> T.Text -> Value-convert ctx t = foldResult (\_ -> String t) (eval ctx) $ parseText parser t+    reg <- view _registry+    lift $ R.insert reg n (getUID component) component -parseText :: Parser a -> T.Text -> Result a-parseText parser = parseByteString parser mempty . TE.encodeUtf8+    lift+      $  Caster.info+      $  "Component registered: {name: "+      <> show (name compConf)+      <> ", uid: "+      <> show (getUID component)+      <> "}" -resolve :: Value -> Value-resolve = \value -> go (Context V.empty HM.empty value) value- where-  go ctx (Object obj)-    | "_vars" `HM.member` obj-    = let vars = obj HM.! "_vars"-      in  go-            ( ctx-              { variables = HM.union ((\(Object o) -> o) $ vars) (variables ctx)-              }-            )-            (Object (HM.delete "_vars" obj))-    | otherwise-    = Object $ HM.mapWithKey-      (\key -> go (ctx { path = V.snoc (path ctx) (Right key) }))-      obj-  go ctx (Array arr) =-    Array $ V.imap (\i -> go (ctx { path = V.snoc (path ctx) (Left i) })) arr-  go ctx (String t) = convert ctx t-  go _ (Number n) = Number n-  go _ (Bool   b) = Bool b-  go _ Null       = Null+    liftIO $ modifyIORef' cref $ \conf -> conf+      { app  = V.snoc (app conf) compConf+      , uuid = V.snoc (uuid conf) newID+      }++  remove n = do+    cref    <- view _appConfig+    appConf <- liftIO $ readIORef cref++    let uid = uuid appConf V.! n++    reg <- view _registry+    lift $ R.delete reg uid+    lift $ Caster.info $ "Component deleted: {uid: " <> show uid <> "}"++    liftIO $ writeIORef cref $ appConf+      { app  = V.ifilter (\i _ -> i /= n) $ app appConf+      , uuid = V.ifilter (\i _ -> i /= n) $ uuid appConf+      }++  modify n op = do+    cref     <- view _appConfig+    appConf  <- liftIO $ readIORef cref++    compConf <-+      case Diff.applyOperation op (toJSON (app appConf V.! n)) >>= fromJSON of+        Success a   -> return a+        Error   err -> do+          lift $ Caster.err err+          fail ""++    let uid = uuid appConf V.! n++    component <- do+      result <- lift $ liftMiniLight $ createComponentBy resolver+                                                         (Just uid)+                                                         compConf++      case result of+        Left err -> do+          lift $ Caster.err $ "Failed to resolve: " <> err+          fail ""+        Right c -> return c++    reg <- view _registry+    lift $ R.write reg uid component+    lift+      $  Caster.info+      $  "Component replaced: {name: "+      <> show (name compConf)+      <> ", uid: "+      <> show (getUID component)+      <> "}"++    liftIO $ writeIORef cref $ appConf { app = app appConf V.// [(n, compConf)]+                                       }

@@ -11,14 +11,11 @@   propagate, ) where +import Control.Lens 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@@ -35,7 +32,7 @@   -> LightT env m () emit et = do   uid <- view uidL-  ref <- view signalQueueL+  ref <- view _signalQueue   liftIO $ modifyIORef' ref $ (signal uid et :)  -- | CompoonentUnit typeclass provides a way to define a new component.@@ -82,10 +79,10 @@ -- | Create a new component. newComponent   :: (ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m)-  => c+  => T.Text+  -> c   -> LightT env m Component-newComponent c = do-  uid  <- liftIO $ Data.UUID.toText <$> Data.UUID.V4.nextRandom+newComponent uid c = do   figs <- figures c   ref  <- liftIO $ newIORef figs   return $ Component {uid = uid, component = c, prev = c, cache = ref}

@@ -13,6 +13,7 @@ import qualified Data.Text as T import Data.Type.Equality import Type.Reflection+import qualified System.FSNotify as Notify  -- | EventType says some type can be used as an event type. class Typeable e => EventType e@@ -34,6 +35,7 @@   = Never   | Signal T.Text Dynamic   | RawEvent SDL.Event+  | NotifyEvent Notify.Event  signal :: EventType a => T.Text -> a -> Event signal t v = Signal t (toDyn v)

@@ -5,12 +5,11 @@ -- | This module provides many convenient operations for textures. module MiniLight.Figure where +import Control.Lens import Control.Monad.Catch import Control.Monad.IO.Class import qualified Data.Text as T import Data.Word (Word8)-import Lens.Micro-import Lens.Micro.Mtl import Linear (_x, _y) import MiniLight.Light import qualified SDL@@ -55,7 +54,7 @@ -- | Render a figure. render :: (HasLightEnv env, MonadIO m, MonadMask m) => Figure -> LightT env m () render fig = do-  renderer <- view rendererL+  renderer <- view _renderer    SDL.copyEx renderer              (texture fig)@@ -140,7 +139,7 @@   {-# INLINE rotate #-}    text font color txt = do-    renderer <- view rendererL+    renderer <- view _renderer      withBlendedText font txt color $ \surf -> do       texture <- SDL.createTextureFromSurface renderer surf@@ -151,7 +150,7 @@   {-# INLINE text #-}    picture filepath = do-    renderer <- view rendererL+    renderer <- view _renderer      texture <- SDL.Image.loadTexture renderer filepath     tinfo <- SDL.queryTexture texture@@ -168,7 +167,7 @@   {-# INLINE fromTexture #-}    rectangleOutline color size = do-    rend <- view rendererL+    rend <- view _renderer     tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fmap toEnum size)     SDL.textureBlendMode tex SDL.$= SDL.BlendAlphaBlend @@ -181,7 +180,7 @@   {-# INLINE rectangleOutline #-}    rectangleFilled color size = do-    rend <- view rendererL+    rend <- view _renderer     tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fmap toEnum size)     SDL.textureBlendMode tex SDL.$= SDL.BlendAlphaBlend @@ -194,7 +193,7 @@   {-# INLINE rectangleFilled #-}    triangleOutline color size = do-    rend <- view rendererL+    rend <- view _renderer     tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fmap toEnum size)     SDL.textureBlendMode tex SDL.$= SDL.BlendAlphaBlend 

@@ -1,5 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE UndecidableInstances #-} module MiniLight.Light (   HasLightEnv (..),   LightT (..),@@ -10,6 +12,7 @@   mapLightT,    HasLoopEnv (..),+  LoopEnv (..),    FontDescriptor(..),   FontStyle(..),@@ -21,28 +24,44 @@   MonadIO(..), ) where +import Control.Concurrent.MVar+import Control.Lens import Control.Monad.IO.Class+import qualified Control.Monad.Caster as Caster import Control.Monad.Catch 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 -type FontMap = HM.HashMap FontDescriptor FilePath- instance Hashable FontDescriptor where   hashWithSalt n fd = let style = _descriptorStyle fd in hashWithSalt n (_descriptorFamilyName fd, _fontStyleBold style, _fontStyleItalic style) -class HasLightEnv env where-  rendererL :: Lens' env SDL.Renderer-  fontCacheL :: Lens' env FontMap +type FontMap = HM.HashMap FontDescriptor FilePath++-- | The environment for LightT monad.+data LightEnv = LightEnv+  { renderer :: SDL.Renderer  -- ^ Renderer for SDL2+  , fontCache :: FontMap  -- ^ System font information+  , logger :: Caster.LogQueue  -- ^ Logger connected stdout+  }++makeClassy_ ''LightEnv++data LoopEnv = LoopEnv+  { keyStates :: HM.HashMap SDL.Scancode Int  -- ^ Current state of keys, represents how many frames the key down has been down+  , events :: MVar [Event]  -- ^ Event queue+  , signalQueue :: IORef [Event]  -- ^ Signals emitted from components are stored in the queue and poll in the next frame.+  }++makeClassy_ ''LoopEnv++ newtype LightT env m a = LightT { runLightT' :: ReaderT env m a }   deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadMask, MonadCatch) @@ -50,25 +69,16 @@   ask = LightT ask   local f = LightT . local f . runLightT' -data LightEnv = LightEnv-  { renderer :: SDL.Renderer-  , fontCache :: FontMap-  }--instance HasLightEnv LightEnv where-  rendererL = lens renderer (\env r -> env { renderer = r })-  fontCacheL = lens fontCache (\env r -> env { fontCache = r })+instance (Monad m, HasLightEnv env) => Caster.MonadLogger (LightT env m) where+  getLogger = view _logger  type MiniLight = LightT LightEnv IO  liftMiniLight :: (HasLightEnv env, MonadIO m) => MiniLight a -> LightT env m a liftMiniLight m = do-  renderer  <- view rendererL-  fontCache <- view fontCacheL+  env <- view lightEnv -  LightT $ ReaderT $ \_ -> liftIO $ runReaderT-    (runLightT' m)-    (LightEnv {renderer = renderer, fontCache = fontCache})+  LightT $ ReaderT $ \_ -> liftIO $ runReaderT (runLightT' m) env {-# INLINE liftMiniLight #-}  envLightT :: (env' -> env) -> LightT env m a -> LightT env' m a@@ -79,16 +89,6 @@ 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   fc <- liftIO buildCache@@ -107,7 +107,7 @@   -> Int   -> LightT env m SDL.Font.Font loadFont fd size = do-  fc <- view fontCacheL+  fc <- view _fontCache   let path = fc HM.! fd   SDL.Font.load path size