freestyle (empty) → 0.1.0.0
raw patch · 6 files changed
+422/−0 lines, 6 filesdep +asyncdep +basedep +freestyle
Dependencies added: async, base, freestyle, prettyprinter, prettyprinter-ansi-terminal, stm, text
Files
- CHANGELOG.md +5/−0
- LICENSE +20/−0
- README.md +53/−0
- freestyle.cabal +42/−0
- lib/Freestyle.hs +164/−0
- test/Main.hs +138/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for renderboy++## 0.1.0.0 -- 5-25-2026++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2026 dopamane++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,53 @@+# Freestyle++Create and display pretty terminal graphics++Construct a new handle and configuration:++ * a way to read state+ * a function to draw the current state+ * a function to layout the current doc+ * a function to render the `SimpleDocStream` to `Text`++Run the configuration using `runFreestyle`.+Note, it has an `Eq ann` constraint. Freestyle re-renders+the terminal if the `SimpleDocStream ann` changes.+This way, apps may make state changes without causing+terminal re-rendering.++The `Freestyle` handle supports on-the-fly+state, draw, layout, and rendering changes. Use dynamic+layout, rendering algorithms based on environment+such as window size.++Example+```hs+import Freestyle++main :: IO ()+main = do+ s <- newTVarIO "FREESTYLE!!!FREESTYLE!!!FREESTYLE!!!"+ f <- newFreestyleIO+ concurrently_ (runFreestyle f $ cfg s) $+ forever $ do+ atomically $ modifyTVar' s rote+ threadDelay 200000+ where+ rote s = last s : init s++cfg :: TVar String -> FreestyleCfg String AnsiStyle+cfg s = FreestyleCfg+ { readState = readTVar s+ , drawState = \s' -> return $+ applyWhen (take 1 s' == "E") (annotate $ color Blue) $ pretty s'+ , layoutDoc = return . layoutPretty defaultLayoutOptions+ , renderDoc = return . renderLazy+ }+```++Development+```+cabal build+cabal run+cabal haddock+```
+ freestyle.cabal view
@@ -0,0 +1,42 @@+cabal-version: 3.0+name: freestyle+version: 0.1.0.0+synopsis: Freestyle TUI graphics+description: Concurrent, pretty terminal graphics+license: MIT+license-file: LICENSE+author: dopamane+maintainer: dwc1295@gmail.com+copyright: (c) David Cox+category: Graphics, Concurrency, STM, Prettyprinter+build-type: Simple+extra-doc-files: CHANGELOG.md+ README.md++source-repository head+ type: git+ location: https://github.com/dopamane/freestyle++library+ ghc-options: -Wall -Wunused-packages -O2+ hs-source-dirs: lib+ default-language: Haskell2010+ exposed-modules: Freestyle+ build-depends: base < 5.0,+ prettyprinter,+ stm,+ text++test-suite test+ ghc-options: -Wall -Wunused-packages -O2 -threaded+ hs-source-dirs: test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Main.hs+ build-depends: async,+ base,+ freestyle,+ prettyprinter,+ prettyprinter-ansi-terminal,+ stm,+ text
+ lib/Freestyle.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Create and display pretty terminal graphics+--+-- Construct a new handle and configuration:+--+-- * a way to read state+-- * a function to draw the current state+-- * a function to layout the current doc+-- * a function to render the 'SimpleDocStream' to 'Text'+--+-- Run the configuration using 'runFreestyle'.+-- Note, it has an 'Eq' constraint. Freestyle re-renders+-- the terminal if the 'SimpleDocStream' changes.+-- This way, apps may make state changes without causing+-- terminal re-rendering.+--+-- The t'Freestyle' handle supports on-the-fly+-- state, draw, layout, and rendering changes. Use dynamic+-- layout, rendering algorithms based on environment+-- such as window size.+--+-- @+-- import Freestyle+--+-- main :: IO ()+-- main = do+-- s <- newTVarIO \"FREESTYLE!!!FREESTYLE!!!FREESTYLE!!!\"+-- f <- newFreestyleIO+-- concurrently_ (runFreestyle f $ cfg s) $+-- forever $ do+-- atomically $ modifyTVar' s rote+-- threadDelay 200000+-- where+-- rote s = last s : init s+--+-- cfg :: TVar String -> FreestyleCfg String AnsiStyle+-- cfg s = FreestyleCfg+-- { readState = readTVar s+-- , drawState = \\s' -> return $+-- applyWhen (take 1 s' == \"E\") (annotate $ color Blue) $ pretty s'+-- , layoutDoc = return . layoutPretty defaultLayoutOptions+-- , renderDoc = return . renderLazy+-- }+-- @+module Freestyle+ ( Freestyle+ , newFreestyle+ , newFreestyleIO+ , FreestyleCfg(..)+ , runFreestyle+ , setLayout+ , setRender+ , setState+ , setDraw+ ) where++import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T+import Data.Text.Lazy.Builder+import qualified Data.Text.Lazy.IO as TIO+import Prettyprinter+import System.IO++-- | TUI handle+data Freestyle s ann = Freestyle+ { lay :: TMVar (Doc ann -> STM (SimpleDocStream ann))+ , ren :: TMVar (SimpleDocStream ann -> STM Text)+ , stateVar :: TMVar (STM s) -- current state+ , drawVar :: TMVar (s -> STM (Doc ann)) -- draw state+ }++-- | Construct a new STM TUI+newFreestyle :: STM (Freestyle s ann)+newFreestyle =+ Freestyle <$> newEmptyTMVar <*> newEmptyTMVar <*> newEmptyTMVar <*> newEmptyTMVar++-- | Construct a new IO TUI+newFreestyleIO :: IO (Freestyle s ann)+newFreestyleIO = atomically newFreestyle++-- | User init configuration.+-- The TUI updates when 'SimpleDocStream' changes.+data FreestyleCfg s ann = FreestyleCfg+ { readState :: STM s -- ^ read the current state+ , drawState :: s -> STM (Doc ann) -- ^ draw the current state+ , layoutDoc :: Doc ann -> STM (SimpleDocStream ann) -- ^ layout the doc+ , renderDoc :: SimpleDocStream ann -> STM Text -- ^ render the doc+ }++-- | Run the TUI with the configuration+runFreestyle :: Eq ann => Freestyle s ann -> FreestyleCfg s ann -> IO a+runFreestyle f cfg = do+ atomically $ do+ setLayout f $ layoutDoc cfg+ setRender f $ renderDoc cfg+ setState f $ readState cfg+ setDraw f $ drawState cfg+ -- without echo+ bracket_ (hSetEcho stdin False) (hSetEcho stdin True) $ do+ hSetBuffering stdout $ BlockBuffering Nothing+ -- without cursor+ bracket_ (output "\x1b[?25l") (output "\x1b[?25h") $+ loop Nothing `finally` output clearScreen+ where+ loop prevM = join $ atomically $ do+ s <- join $ readTMVar $ stateVar f+ draw <- readTMVar $ drawVar f+ layo <- readTMVar $ lay f+ rend <- readTMVar $ ren f+ sds' <- layo =<< draw s+ case prevM of+ Nothing -> do+ t <- rend sds'+ return $ do+ output $ clearScreen <> t+ loop $ Just (sds', t)+ Just (sds, p) -> do+ check $ sds /= sds'+ t <- rend sds'+ return $ do+ output $ composite t p+ loop $ Just (sds', t)++-- | Change the layout algorithm+setLayout :: Freestyle s ann -> (Doc ann -> STM (SimpleDocStream ann)) -> STM ()+setLayout f = writeTMVar $ lay f++-- | Change the rendering algorithm+setRender :: Freestyle s ann -> (SimpleDocStream ann -> STM Text) -> STM ()+setRender f = writeTMVar $ ren f++-- | Change the state reader+setState :: Freestyle s ann -> STM s -> STM ()+setState f = writeTMVar $ stateVar f++-- | Change the drawing algorithm+setDraw :: Freestyle s ann -> (s -> STM (Doc ann)) -> STM ()+setDraw f = writeTMVar $ drawVar f++-- | write stdout and flush+output :: Text -> IO ()+output t = TIO.putStr t >> hFlush stdout++-- | erase screen and goto home+clearScreen :: Text+clearScreen = "\x1b[2J\x1b[H"++-- | construct line diff rewrites+composite :: Text -> Text -> Text+composite new old = toLazyText $ go 0 (T.lines new) (T.lines old)+ where+ go _ ns [] = fromLazyText $ T.unlines ns+ go _ [] (_:_) = "\x1b[J"+ go r (n:ns) (o:os) = mconcat+ [ if n /= o then movRow <> fromLazyText n else mempty+ , if T.length o > T.length n then "\x1b[0K" else mempty -- erase line+ , go (r + 1) ns os+ ]+ where+ movRow = "\x1b[" <> fromString (show (r + 1 :: Int)) <> "H"
+ test/Main.hs view
@@ -0,0 +1,138 @@+module Main (main) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Monad+import Data.Semigroup+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T+import Freestyle+import Prettyprinter+import Prettyprinter.Render.Util.SimpleDocTree+import Prettyprinter.Render.Terminal+import System.IO++main :: IO ()+main = join $ atomically $ do+ s <- newTVar initMain+ f <- newFreestyle+ return $ mapConcurrently_ id+ [ runFreestyle f $ mainCfg s+ , runWheel s+ , runKeyReader s+ , runWaterfall s+ ]++data Main = Main+ { colorWheel :: [Color]+ , offset :: Double+ , switch :: Bool+ , waterfall :: [[Color]]+ }+ deriving Eq++initMain :: Main+initMain = Main+ { colorWheel = [Red, Green, Yellow, Blue]+ , offset = 0+ , switch = False+ , waterfall =+ [ rotate i r+ | (i, r) <- zip [1..] $ replicate 25 $ stimes (5 :: Int)+ [Blue, Green, Blue, Blue, Yellow, Red, Cyan, Green, Blue]+ ]+ }++mainCfg :: TVar Main -> FreestyleCfg Main Style+mainCfg s = FreestyleCfg+ { readState = readTVar s+ , layoutDoc = return . layoutPretty defaultLayoutOptions+ , renderDoc = return . renderDisplay+ , drawState = mainDraw+ }++mainDraw :: Main -> STM (Doc Style)+mainDraw (Main cs rads en wf) =+ return $ vsep+ [ hcat $ zipWith renderColorChar (cycle cs) "~~~~~~~~~~ Freestyle!"+ , renderSin rads+ , pretty $ if en then "ON" else "OFF"+ , drawWaterfall wf+ ]++runWheel :: TVar Main -> IO a+runWheel s = forever $ do+ atomically $ modifyTVar' s updateWheel+ threadDelay 100000+ where+ updateWheel m@(Main cs o _ _) = m{colorWheel=cs', offset=o'}+ where+ cs' = drop 1 cs <> take 1 cs+ o' = o + 0.1++runKeyReader :: TVar Main -> IO a+runKeyReader s = do+ hSetBuffering stdin NoBuffering+ forever $ do+ ch <- getChar+ when (ch == 'a') $+ atomically $ modifyTVar' s $ \m -> m{switch=not $ switch m}++runWaterfall :: TVar Main -> IO a+runWaterfall s = forever $ do+ atomically $ modifyTVar' s $ \m ->+ m{waterfall=cycleWaterfall $ waterfall m}+ threadDelay 50000++rotate :: Int -> [a] -> [a]+rotate _ [] = []+rotate n xs = zipWith const (drop n (cycle xs)) xs++drawWaterfall :: [[Color]] -> Doc Style+drawWaterfall rs = vsep [renderRow r | r <- rs]+ where+ renderRow r = hcat [renderCell c | c <- r]+ where+ renderCell c = annotate (Ansi $ bgColor c) space++cycleWaterfall :: [[Color]] -> [[Color]]+cycleWaterfall w = drop 1 w <> take 1 w++renderSin :: Double -> Doc ann+renderSin o = vsep [renderRow r | r <- [-5..5]]+ where+ renderRow r = hcat [renderCell c | c <- [0..31]]+ where+ renderCell c+ | floor (y * 5) == (r :: Integer) = pretty "*"+ | otherwise = pretty " "+ where+ y = sin (c / 10 + o)++renderColorChar :: Color -> Char -> Doc Style+renderColorChar clr ch = annotate (Ansi $ color clr) $ pretty ch++renderDisplay :: SimpleDocStream Style -> Text+renderDisplay = renderSdt . treeForm++renderSdt :: SimpleDocTree Style -> Text+renderSdt sdt = case sdt of+ STEmpty -> mempty+ STChar c -> T.singleton c+ STText _ t -> T.fromStrict t+ STLine i -> T.singleton '\n' <> T.replicate (fromIntegral i) (T.singleton ' ')+ STAnn ann rest -> renderStyle ann rest $ renderSdt rest+ STConcat xs -> foldMap renderSdt xs++renderStyle :: Style -> SimpleDocTree Style -> Text -> Text+renderStyle d _ s = case d of+ Ansi a -> go $ annotate a $ pretty s+ Title -> go $ annotate (bold <> underlined <> color Blue) $ pretty s+ where+ go = renderLazy . layoutPretty defaultLayoutOptions++data Style+ = Ansi AnsiStyle+ | Title+ deriving (Eq, Show)