diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,137 +0,0 @@ -# This Travis job script has been generated by a script via -# -# haskell-ci 'termbox-banana.cabal' -# -# For more information, see https://github.com/haskell-CI/haskell-ci -# -# version: 0.3.20190521 -# -language: c -dist: xenial -git: - # whether to recursively clone submodules - submodules: false -cache: - directories: - - $HOME/.cabal/packages - - $HOME/.cabal/store -before_cache: - - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log - # remove files that are regenerated by 'cabal update' - - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - - rm -rfv $CABALHOME/packages/head.hackage -matrix: - include: - - compiler: ghc-8.6.5 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}} - - compiler: ghc-8.4.4 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}} -before_install: - - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - - HCPKG="$HC-pkg" - - unset CC - - CABAL=/opt/ghc/bin/cabal - - CABALHOME=$HOME/.cabal - - export PATH="$CABALHOME/bin:$PATH" - - TOP=$(pwd) - - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) - - echo $HCNUMVER - - CABAL="$CABAL -vnormal+nowrap+markoutput" - - set -o pipefail - - | - echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk - echo 'BEGIN { state = "output"; }' >> .colorful.awk - echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk - echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk - echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk - echo ' if (state == "cabal") {' >> .colorful.awk - echo ' print blue($0)' >> .colorful.awk - echo ' } else {' >> .colorful.awk - echo ' print $0' >> .colorful.awk - echo ' }' >> .colorful.awk - echo '}' >> .colorful.awk - - cat .colorful.awk - - | - color_cabal_output () { - awk -f $TOP/.colorful.awk - } - - echo text | color_cabal_output -install: - - ${CABAL} --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - TEST=--enable-tests - - BENCH=--enable-benchmarks - - GHCHEAD=${GHCHEAD-false} - - rm -f $CABALHOME/config - - | - echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config - echo "remote-build-reporting: anonymous" >> $CABALHOME/config - echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config - echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config - echo "world-file: $CABALHOME/world" >> $CABALHOME/config - echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config - echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config - echo "installdir: $CABALHOME/bin" >> $CABALHOME/config - echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config - echo "store-dir: $CABALHOME/store" >> $CABALHOME/config - echo "install-dirs user" >> $CABALHOME/config - echo " prefix: $CABALHOME" >> $CABALHOME/config - echo "repository hackage.haskell.org" >> $CABALHOME/config - echo " url: http://hackage.haskell.org/" >> $CABALHOME/config - - cat $CABALHOME/config - - rm -fv cabal.project cabal.project.local cabal.project.freeze - - travis_retry ${CABAL} v2-update -v - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo 'packages: "."' >> cabal.project - - | - echo "write-ghc-environment-files: always" >> cabal.project - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(termbox-banana)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - - ${CABAL} v2-freeze -w ${HC} ${TEST} ${BENCH} | color_cabal_output - - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - - rm cabal.project.freeze - - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all | color_cabal_output - - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output -script: - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - # Packaging... - - ${CABAL} v2-sdist all | color_cabal_output - # Unpacking... - - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - - cd ${DISTDIR} || false - - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo 'packages: "termbox-banana-*/*.cabal"' >> cabal.project - - | - echo "write-ghc-environment-files: always" >> cabal.project - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(termbox-banana)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - # Building... - # this builds all libraries and executables (without tests/benchmarks) - - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks all | color_cabal_output - # Building with tests and benchmarks... - # build & run tests, build benchmarks - - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} all | color_cabal_output - # cabal check... - - (cd termbox-banana-* && ${CABAL} -vnormal check) - # haddock... - - ${CABAL} v2-haddock -w ${HC} ${TEST} ${BENCH} all | color_cabal_output - # Building without installed constraints for packages in global-db... - - rm -f cabal.project.local - - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks all | color_cabal_output - -# REGENDATA ["termbox-banana.cabal"] -# EOF diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,15 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/) and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [0.3.0] - 2020-09-20 + +### Changed +- Support GHC 8.8, GHC 8.10 +- Depend on `termbox ==0.3` + +### Removed +- Removed `Scene` + ## [0.2.0] - 2019-06-28 ### Added diff --git a/examples/Echo.hs b/examples/Echo.hs --- a/examples/Echo.hs +++ b/examples/Echo.hs @@ -1,56 +1,49 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -module Main where +module Main (main) where import Reactive.Banana import Reactive.Banana.Frameworks - import qualified Termbox.Banana as Termbox main :: IO () main = - Termbox.run_ - (Termbox.InputModeEsc Termbox.MouseModeNo) - Termbox.OutputModeNormal - moment + Termbox.run moment -moment - :: Event Termbox.Event - -> Behavior (Int, Int) - -> MomentIO (Behavior Termbox.Scene, Event ()) +moment :: + Event Termbox.Event -> + Behavior (Int, Int) -> + MomentIO (Behavior (Termbox.Cells, Termbox.Cursor), Event ()) moment eEvent _bSize = do - let - eQuit :: Event () - eQuit = - () <$ filterE isKeyEsc eEvent + let eQuit :: Event () + eQuit = + () <$ filterE isKeyEsc eEvent bLatestEvent :: Behavior (Maybe Termbox.Event) <- stepper Nothing (Just <$> eEvent) - let - bCells :: Behavior Termbox.Cells - bCells = - maybe mempty renderEvent <$> bLatestEvent + let bCells :: Behavior Termbox.Cells + bCells = + maybe mempty renderEvent <$> bLatestEvent - let - bScene :: Behavior Termbox.Scene - bScene = - Termbox.Scene - <$> bCells - <*> pure Termbox.NoCursor + let bScene :: Behavior (Termbox.Cells, Termbox.Cursor) + bScene = + (,) + <$> bCells + <*> pure Termbox.NoCursor pure (bScene, eQuit) renderEvent :: Termbox.Event -> Termbox.Cells renderEvent = foldMap (\(i, c) -> Termbox.set i 0 (Termbox.Cell c mempty mempty)) - . zip [0..] + . zip [0 ..] . show isKeyEsc :: Termbox.Event -> Bool isKeyEsc = \case - Termbox.EventKey Termbox.KeyEsc _ -> True + Termbox.EventKey Termbox.KeyEsc -> True _ -> False diff --git a/examples/Hoogle.hs b/examples/Hoogle.hs --- a/examples/Hoogle.hs +++ b/examples/Hoogle.hs @@ -1,7 +1,7 @@ -{-# language LambdaCase #-} -{-# language OverloadedStrings #-} -{-# language RecursiveDo #-} -{-# language ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where @@ -22,21 +22,17 @@ import Network.HTTP.Simple import Reactive.Banana import Reactive.Banana.Frameworks -import Text.HTML.TagSoup - import qualified Termbox.Banana as Termbox +import Text.HTML.TagSoup main :: IO () main = - Termbox.run_ - (Termbox.InputModeEsc Termbox.MouseModeNo) - Termbox.OutputModeNormal - moment + Termbox.run moment -moment - :: Event Termbox.Event - -> Behavior (Int, Int) - -> MomentIO (Behavior Termbox.Scene, Event ()) +moment :: + Event Termbox.Event -> + Behavior (Int, Int) -> + MomentIO (Behavior (Termbox.Cells, Termbox.Cursor), Event ()) moment eEvent bSize = mdo eTick :: Event () <- makeTickEvent @@ -47,13 +43,11 @@ eSearchBox :: Event String <- makeSearchBoxEvent eKey - reactimate - ((atomically . writeTQueue requestQueue . reverse) <$> eSearchBox) + reactimate ((atomically . writeTQueue requestQueue . reverse) <$> eSearchBox) - let - eEmptySearchBox :: Event String - eEmptySearchBox = - filterE null eSearchBox + let eEmptySearchBox :: Event String + eEmptySearchBox = + filterE null eSearchBox bSearchBox :: Behavior String <- stepper "" eSearchBox @@ -69,53 +63,54 @@ bSearchResults :: Behavior (Either SomeException [Value]) <- stepper (Right []) - (unionWith - const - (Right [] <$ eEmptySearchBox) - eSearchResults) + ( unionWith + const + (Right [] <$ eEmptySearchBox) + eSearchResults + ) bSpinnerFrame :: Behavior (Maybe Int) <- - accumB Nothing (unions - [ ((\query -> - if null query - then const Nothing - else const (Just 1)) - <$> eSearchBox) - , const Nothing <$ eSearchResults - , const Nothing <$ eEmptySearchBox - , fmap (+1) <$ whenE (isJust <$> bSpinnerFrame) eTick - ]) + accumB + Nothing + ( unions + [ ( ( \query -> + if null query + then const Nothing + else const (Just 1) + ) + <$> eSearchBox + ), + const Nothing <$ eSearchResults, + const Nothing <$ eEmptySearchBox, + fmap (+ 1) <$ whenE (isJust <$> bSpinnerFrame) eTick + ] + ) - let - bCells :: Behavior Termbox.Cells - bCells = - render - <$> bHeight - <*> bSearchBox - <*> bSearchResults - <*> bSpinnerFrame + let bCells :: Behavior Termbox.Cells + bCells = + render + <$> bHeight + <*> bSearchBox + <*> bSearchResults + <*> bSpinnerFrame - let - bCursor :: Behavior Termbox.Cursor - bCursor = - (\height searchBox -> Termbox.Cursor (length searchBox + 2) height) - <$> bHeight - <*> bSearchBox + let bCursor :: Behavior Termbox.Cursor + bCursor = + (\height searchBox -> Termbox.Cursor (length searchBox + 2) height) + <$> bHeight + <*> bSearchBox - let - bScene :: Behavior Termbox.Scene - bScene = - Termbox.Scene - <$> bCells - <*> bCursor + let bScene :: Behavior (Termbox.Cells, Termbox.Cursor) + bScene = + (,) + <$> bCells + <*> bCursor pure (bScene, () <$ filterE (== Termbox.KeyEsc) eKey) - where eKey :: Event Termbox.Key eKey = filterJust (eventAsKey <$> eEvent) - bHeight :: Behavior Int bHeight = snd <$> bSize @@ -128,56 +123,59 @@ threadDelay 100000 pure e -makeSearchBoxEvent - :: MonadMoment m - => Event Termbox.Key - -> m (Event String) +makeSearchBoxEvent :: + MonadMoment m => + Event Termbox.Key -> + m (Event String) makeSearchBoxEvent eKey = accumE "" - (unions - [ (:) <$> filterJust (keyAsChar <$> eKey) - , (' ' :) <$ filterE (== Termbox.KeySpace) eKey - , safeTail <$ filterE (== Termbox.KeyBackspace2) eKey - ]) + ( unions + [ (:) <$> filterJust (keyAsChar <$> eKey), + (' ' :) <$ filterE (== Termbox.KeySpace) eKey, + safeTail <$ filterE (== Termbox.KeyCtrl8) eKey + ] + ) -runHttpRequestThread - :: TQueue String -- ^ Request queue - -> (Either SomeException [Value] -> IO ()) -- ^ Response callback - -> IO () +runHttpRequestThread :: + -- | Request queue + TQueue String -> + -- | Response callback + (Either SomeException [Value] -> IO ()) -> + IO () runHttpRequestThread requestQueue respond = loop Nothing where loop :: Maybe (Async [Value]) -> IO () loop maybeInFlightRequest = join . atomically $ - (do - query <- readTQueue requestQueue - pure $ do - for_ maybeInFlightRequest $ \inFlightRequest -> - forkIO (cancel inFlightRequest) - if null query - then - loop Nothing - else do - inFlightRequest <- async (performHoogleSearch query) - loop (Just inFlightRequest)) - <|> - (case maybeInFlightRequest of - Nothing -> - retry - Just inFlightRequest -> do - response <- waitCatchSTM inFlightRequest + ( do + query <- readTQueue requestQueue pure $ do - respond response - loop Nothing) + for_ maybeInFlightRequest $ \inFlightRequest -> + forkIO (cancel inFlightRequest) + if null query + then loop Nothing + else do + inFlightRequest <- async (performHoogleSearch query) + loop (Just inFlightRequest) + ) + <|> ( case maybeInFlightRequest of + Nothing -> + retry + Just inFlightRequest -> do + response <- waitCatchSTM inFlightRequest + pure $ do + respond response + loop Nothing + ) -render - :: Int - -> String - -> Either SomeException [Value] - -> Maybe Int - -> Termbox.Cells +render :: + Int -> + String -> + Either SomeException [Value] -> + Maybe Int -> + Termbox.Cells render height searchBox searchResults spinnerFrame = fold [ case searchResults of @@ -186,56 +184,52 @@ Right results -> renderSearchResults height results & execWriterT - & (`evalState` 0) - , renderSearchBox height searchBox spinnerFrame + & (`evalState` 0), + renderSearchBox height searchBox spinnerFrame ] renderSearchBox :: Int -> String -> Maybe Int -> Termbox.Cells renderSearchBox height searchBox spinnerFrame = - renderString 0 (height-1) (promptChar : ' ' : reverse searchBox) + renderString 0 (height -1) (promptChar : ' ' : reverse searchBox) where promptChar :: Char promptChar = case spinnerFrame of Nothing -> 'λ' - Just n -> - let - cs = - "⣧⣏⡟⠿⢻⣹⣼⣶" - in - cs !! (n `mod` length cs) + Just n -> + let cs = + "⣧⣏⡟⠿⢻⣹⣼⣶" + in cs !! (n `mod` length cs) -renderSearchResults - :: Int - -> [Value] - -> WriterT Termbox.Cells (State Int) () +renderSearchResults :: + Int -> + [Value] -> + WriterT Termbox.Cells (State Int) () renderSearchResults height = \case [] -> pure () - result : results -> do row <- get - let - ss = searchResultToLines result + let ss = searchResultToLines result - when (row + length ss < height-1) $ do - for_ (zip [row..] ss) $ \(r, s) -> + when (row + length ss < height -1) $ do + for_ (zip [row ..] ss) $ \(r, s) -> tell (renderString 0 r s) modify' (+ (length ss + 1)) renderSearchResults height results -renderSearchResultsError - :: Int - -> SomeException - -> Termbox.Cells +renderSearchResultsError :: + Int -> + SomeException -> + Termbox.Cells renderSearchResultsError height ex = ex & show & lines & take height - & zip [0..] + & zip [0 ..] & foldMap (\(row, line) -> renderString 0 row line) searchResultToLines :: Value -> [String] @@ -243,23 +237,20 @@ case result ^?! key "type" of "" -> unwords - [ "[" ++ resultPackage result ++ "]" - , "[" ++ resultModule result ++ "]" - , resultItem result + [ "[" ++ resultPackage result ++ "]", + "[" ++ resultModule result ++ "]", + resultItem result ] : map (" " ++) (resultDocs result) - "module" -> unwords - [ "[" ++ resultPackage result ++ "]" - , "[" ++ drop 7 (resultItem result) ++ "]" + [ "[" ++ resultPackage result ++ "]", + "[" ++ drop 7 (resultItem result) ++ "]" ] : map (" " ++) (resultDocs result) - "package" -> ("[" ++ drop 8 (resultItem result) ++ "]") : map (" " ++) (resultDocs result) - _ -> error (show result) @@ -296,21 +287,17 @@ . to htmlToText . to lines . to collapseLines - where collapseLines :: [String] -> [String] collapseLines = \case [] -> [] - [""] -> [] - "" : ss -> case collapseLines ss of "" : ts -> "" : ts - ts -> "" : ts - + ts -> "" : ts s : ss -> s : collapseLines ss @@ -320,11 +307,10 @@ TagText text <- parseTags html pure text - renderString :: Int -> Int -> String -> Termbox.Cells renderString col row = - foldMap (\(i, c) -> Termbox.set i row (Termbox.Cell c mempty mempty)) . - zip [col..] + foldMap (\(i, c) -> Termbox.set i row (Termbox.Cell c mempty mempty)) + . zip [col ..] performHoogleSearch :: String -> IO [Value] performHoogleSearch query = @@ -336,7 +322,7 @@ eventAsKey :: Termbox.Event -> Maybe Termbox.Key eventAsKey = \case - Termbox.EventKey k _ -> Just k + Termbox.EventKey k -> Just k _ -> Nothing keyAsChar :: Termbox.Key -> Maybe Char @@ -347,4 +333,4 @@ safeTail :: [a] -> [a] safeTail = \case [] -> [] - _:xs -> xs + _ : xs -> xs diff --git a/src/Termbox/Banana.hs b/src/Termbox/Banana.hs --- a/src/Termbox/Banana.hs +++ b/src/Termbox/Banana.hs @@ -1,62 +1,58 @@ -{-# language DerivingStrategies #-} -{-# language GeneralizedNewtypeDeriving #-} -{-# language LambdaCase #-} -{-# language ScopedTypeVariables #-} -{-# language TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} module Termbox.Banana ( -- $intro - TermboxEvent - , run - , run_ - , set - , Scene(..) - , Cells - , Cursor(..) + TermboxEvent, + run, + -- * Re-exports - , Termbox.black - , Termbox.red - , Termbox.green - , Termbox.yellow - , Termbox.blue - , Termbox.magenta - , Termbox.cyan - , Termbox.white - , Termbox.bold - , Termbox.underline - , Termbox.reverse - , Termbox.Attr - , Termbox.Cell(..) - , Termbox.Event(..) - , Termbox.InitError(..) - , Termbox.InputMode(..) - , Termbox.Key(..) - , Termbox.Mouse(..) - , Termbox.MouseMode(..) - , Termbox.OutputMode(..) + Termbox.black, + Termbox.blue, + Termbox.bold, + Termbox.cyan, + Termbox.green, + Termbox.magenta, + Termbox.red, + Termbox.reverse, + Termbox.underline, + Termbox.white, + Termbox.yellow, + Termbox.set, + Termbox.Attr, + Termbox.Cell (..), + Termbox.Cells, + Termbox.Cursor (..), + Termbox.Event (..), + Termbox.InitError (..), + Termbox.Key (..), + pattern Termbox.KeyCtrl2, + pattern Termbox.KeyCtrl3, + pattern Termbox.KeyCtrl4, + pattern Termbox.KeyCtrl5, + pattern Termbox.KeyCtrl7, + pattern Termbox.KeyCtrlH, + pattern Termbox.KeyCtrlI, + pattern Termbox.KeyCtrlLsqBracket, + pattern Termbox.KeyCtrlM, + pattern Termbox.KeyCtrlUnderscore, + Termbox.Mouse (..), + Termbox.PollError (..), + -- * Example -- $example - ) where + ) +where import Control.Concurrent.MVar -import Control.Exception (throwIO) import Data.Function (fix) import Reactive.Banana import Reactive.Banana.Frameworks - import qualified Termbox - -- $intro -- See the bottom of this module for a simple, runnable example to get started. -- --- Here's how to run the examples with @cabal@: --- --- @ --- cabal v2-run --constraint "termbox-banana +build-examples" termbox-banana-example-echo --- cabal v2-run --constraint "termbox-banana +build-examples" termbox-banana-example-hoogle --- @ --- -- This module is intended to be imported qualified. -- -- @ @@ -68,42 +64,11 @@ -- -- * @Event@ for @reactive-banana@ events -- * @Termbox.Event@ for @termbox@ events --- --- @since 0.1.0 -type TermboxEvent - = Termbox.Event - --- | A scene to render; a grid of cells and a cursor. --- --- @since 0.1.0 -data Scene - = Scene !Cells !Cursor - --- | A grid of cells. --- --- Create a 'Cells' with 'set' or 'mempty' and combine them with ('<>'). --- --- @since 0.1.0 -newtype Cells - = Cells (IO ()) - deriving newtype (Monoid, Semigroup) - --- | A cursor. --- --- @since 0.1.0 -data Cursor - = Cursor !Int !Int -- ^ Column, then row - | NoCursor - --- | Set a single cell's value (column, then row). --- --- @since 0.1.0 -set :: Int -> Int -> Termbox.Cell -> Cells -set x y z = - Cells (Termbox.set x y z) +type TermboxEvent = + Termbox.Event -type EventSource a - = (AddHandler a, a -> IO ()) +type EventSource a = + (AddHandler a, a -> IO ()) -- | Run a @termbox@ program with the specified input and output modes. -- @@ -117,20 +82,14 @@ -- * a time-varying scene to render -- * an event stream of arbitrary values, only the first of which is relevant, -- which ends the @termbox@ program and returns from the @main@ action. --- --- @since 0.2.0 -run - :: Termbox.InputMode -- ^ - -> Termbox.OutputMode -- ^ - -> ( Event TermboxEvent - -> Behavior (Int, Int) - -> MomentIO (Behavior Scene, Event a)) - -> IO (Either Termbox.InitError a) -run imode omode program = - Termbox.run $ do - Termbox.setInputMode imode - Termbox.setOutputMode omode - +run :: + ( Event TermboxEvent -> + Behavior (Int, Int) -> + MomentIO (Behavior (Termbox.Cells, Termbox.Cursor), Event a) + ) -> + IO a +run program = + Termbox.run $ \width height render poll -> do doneVar :: MVar a <- newEmptyMVar @@ -142,69 +101,47 @@ eEvent :: Event TermboxEvent <- fromAddHandler eventAddHandler - let - eResize :: Event (Int, Int) - eResize = - filterJust - ((\case - Termbox.EventResize w h -> Just (w, h) - _ -> Nothing) - <$> eEvent) + let eResize :: Event (Int, Int) + eResize = + filterJust + ( ( \case + Termbox.EventResize w h -> Just (w, h) + _ -> Nothing + ) + <$> eEvent + ) bSize :: Behavior (Int, Int) <- - flip stepper eResize =<< - liftIO Termbox.getSize + flip stepper eResize (width, height) - moment program eEvent bSize (putMVar doneVar) + moment (uncurry render) program eEvent bSize (putMVar doneVar) actuate network fix $ \loop -> do - Termbox.poll >>= fireEvent - tryReadMVar doneVar >>= - maybe loop pure - --- | Like 'run', but throws 'Termbox.InitError's as @IO@ exceptions. --- --- @since 0.2.0 -run_ - :: Termbox.InputMode -- ^ - -> Termbox.OutputMode -- ^ - -> ( Event TermboxEvent - -> Behavior (Int, Int) - -> MomentIO (Behavior Scene, Event a)) - -> IO a -run_ imode omode program = - run imode omode program >>= either throwIO pure + poll >>= fireEvent + tryReadMVar doneVar >>= maybe loop pure -moment - :: ( Event TermboxEvent - -> Behavior (Int, Int) - -> MomentIO (Behavior Scene, Event a)) - -> Event TermboxEvent - -> Behavior (Int, Int) - -> (a -> IO ()) - -> MomentIO () -moment program eEvent bSize abort = do - (bScene, eDone) :: (Behavior Scene, Event a) <- +moment :: + ((Termbox.Cells, Termbox.Cursor) -> IO ()) -> + ( Event TermboxEvent -> + Behavior (Int, Int) -> + MomentIO (Behavior (Termbox.Cells, Termbox.Cursor), Event a) + ) -> + Event TermboxEvent -> + Behavior (Int, Int) -> + (a -> IO ()) -> + MomentIO () +moment render program eEvent bSize abort = do + (bScene, eDone) :: (Behavior (Termbox.Cells, Termbox.Cursor), Event a) <- program eEvent bSize - eScene :: Event (Future Scene) <- + eScene :: Event (Future (Termbox.Cells, Termbox.Cursor)) <- changes bScene - let - render :: Scene -> IO () - render (Scene (Cells cells) cursor) = do - Termbox.clear mempty mempty - cells - case cursor of - Cursor c r -> Termbox.setCursor c r - NoCursor -> Termbox.hideCursor - Termbox.flush - liftIO . render =<< valueB bScene reactimate (abort <$> eDone) - reactimate' ((fmap.fmap) render eScene) + reactimate' ((fmap . fmap) render eScene) -- $example -- @@ -224,15 +161,12 @@ -- -- main :: IO () -- main = --- Termbox.'run_' --- (Termbox.'Termbox.InputModeEsc' Termbox.'Termbox.MouseModeNo') --- Termbox.'Termbox.OutputModeNormal' --- moment +-- Termbox.'run' moment -- -- moment -- :: Event Termbox.'Termbox.Event' -- -> Behavior (Int, Int) --- -> MomentIO (Behavior Termbox.'Termbox.Scene', Event ()) +-- -> MomentIO (Behavior (Termbox.'Termbox.Cells', Termbox.'Termbox.Cursor'), Event ()) -- moment eEvent _bSize = do -- let -- eQuit :: Event () @@ -250,9 +184,9 @@ -- maybe mempty renderEvent \<$\> bLatestEvent -- -- let --- bScene :: Behavior Termbox.'Termbox.Scene' +-- bScene :: Behavior (Termbox.'Termbox.Cells', Termbox.'Termbox.Cursor') -- bScene = --- Termbox.'Termbox.Scene' +-- (,) -- \<$\> bCells -- \<*\> pure Termbox.'Termbox.NoCursor' -- diff --git a/termbox-banana.cabal b/termbox-banana.cabal --- a/termbox-banana.cabal +++ b/termbox-banana.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: termbox-banana -version: 0.2.0 +version: 0.3.0 category: User Interfaces description: A @reactive-banana@-based interface to writing @termbox@ programs. @@ -23,99 +23,79 @@ maintainer: Mitchell Rosen homepage: https://github.com/mitchellwrosen/termbox-banana bug-reports: https://github.com/mitchellwrosen/termbox-banana/issues -copyright: (c) 2018-2019, Mitchell Rosen +copyright: (c) 2018-2020, Mitchell Rosen license: BSD-3-Clause license-file: LICENSE build-type: Simple -tested-with: GHC == 8.4.4, GHC == 8.6.5 extra-source-files: - .travis.yml CHANGELOG.md README.md +source-repository head + type: git + location: git://github.com/mitchellwrosen/termbox-banana.git + flag build-examples description: Build example executables default: False manual: True -library - build-depends: - base ^>= 4.10 || ^>= 4.11 || ^>= 4.12 - , reactive-banana ^>= 1.2 - , termbox ^>= 0.2 - - default-language: - Haskell2010 - - exposed-modules: - Termbox.Banana - +common component + default-extensions: + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + default-language: Haskell2010 ghc-options: - -Wall - -Wcompat - -Widentities - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wmissing-export-lists - -Wnoncanonical-monad-instances - -Wnoncanonical-monadfail-instances - -Wpartial-fields - -Wredundant-constraints - -fprint-expanded-synonyms - -fprint-explicit-foralls - -fprint-explicit-kinds - -fprint-unicode-syntax - - hs-source-dirs: - src + -Weverything + -Wno-implicit-prelude + -Wno-missing-import-lists + -Wno-missing-local-signatures + -Wno-monomorphism-restriction + -Wno-safe + -Wno-unsafe + if impl(ghc >= 8.10) + ghc-options: + -Wno-missing-safe-haskell-mode + -Wno-prepositive-qualified-module -executable termbox-banana-example-echo +common example-executable + import: component if !flag(build-examples) buildable: False - build-depends: base, reactive-banana, termbox-banana, - - default-language: - Haskell2010 - - ghc-options: - -Wall -threaded "-with-rtsopts=-N" + ghc-options: -Wall -threaded "-with-rtsopts=-N" + hs-source-dirs: examples - hs-source-dirs: - examples +library + import: component + build-depends: + base ^>= 4.10 || ^>= 4.11 || ^>= 4.12 || ^>= 4.13 || ^>= 4.14 + , reactive-banana ^>= 1.2 + , termbox ^>= 0.3 + exposed-modules: Termbox.Banana + hs-source-dirs: src - main-is: - Echo.hs +executable termbox-banana-example-echo + import: example-executable + ghc-options: -Wall -threaded "-with-rtsopts=-N" + main-is: Echo.hs executable termbox-banana-example-hoogle + import: example-executable if !flag(build-examples) buildable: False - build-depends: aeson, async, - base, http-conduit, lens, lens-aeson, mtl, - reactive-banana, stm, tagsoup, - termbox-banana, - - default-language: - Haskell2010 - - ghc-options: - -Wall -threaded "-with-rtsopts=-N" - - hs-source-dirs: - examples - - main-is: - Hoogle.hs + main-is: Hoogle.hs