diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,31 +5,27 @@ 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.1] - 2022-04-02 + +- Removed example executables + ## [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 - Added `run` - -### Changed - Renamed `main` to `run_` - Bumped `termbox` lower bound ## [0.1.1] - 2019-04-19 -### Changed - Removed unnecessary `stm` dependency - Bumped `base` upper bound ## [0.1.0] - 2018-07-22 -### Added - Initial release diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,6 @@ # `termbox-banana` -[![Build Status](https://travis-ci.org/mitchellwrosen/termbox-banana.svg?branch=master)](https://travis-ci.org/mitchellwrosen/termbox-banana) -![Hackage](https://img.shields.io/hackage/v/termbox-banana.svg) +[![GitHub CI](https://github.com/mitchellwrosen/termbox-banana/workflows/CI/badge.svg)](https://github.com/mitchellwrosen/termbox-banana/actions) +[![Hackage](https://img.shields.io/hackage/v/termbox-banana.svg)](https://hackage.haskell.org/package/termbox-banana) +[![Stackage LTS](https://stackage.org/package/termbox-banana/badge/lts)](https://www.stackage.org/lts/package/termbox-banana) +[![Stackage Nightly](https://stackage.org/package/termbox-banana/badge/nightly)](https://www.stackage.org/nightly/package/termbox-banana) diff --git a/examples/Echo.hs b/examples/Echo.hs deleted file mode 100644 --- a/examples/Echo.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Main (main) where - -import Reactive.Banana -import Reactive.Banana.Frameworks -import qualified Termbox.Banana as Termbox - -main :: IO () -main = - Termbox.run moment - -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 - - bLatestEvent :: Behavior (Maybe Termbox.Event) <- - stepper - Nothing - (Just <$> eEvent) - - let bCells :: Behavior Termbox.Cells - bCells = - maybe mempty renderEvent <$> bLatestEvent - - 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 ..] - . show - -isKeyEsc :: Termbox.Event -> Bool -isKeyEsc = \case - Termbox.EventKey Termbox.KeyEsc -> True - _ -> False diff --git a/examples/Hoogle.hs b/examples/Hoogle.hs deleted file mode 100644 --- a/examples/Hoogle.hs +++ /dev/null @@ -1,336 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Main where - -import Control.Concurrent -import Control.Concurrent.Async -import Control.Concurrent.STM -import Control.Exception (SomeException) -import Control.Lens -import Control.Monad -import Control.Monad.State.Strict -import Control.Monad.Writer.Strict -import Data.Aeson (Value) -import Data.Aeson.Lens -import Data.Foldable (fold, for_) -import Data.Maybe -import Data.String (fromString) -import Data.Text.Lens (unpacked) -import Network.HTTP.Simple -import Reactive.Banana -import Reactive.Banana.Frameworks -import qualified Termbox.Banana as Termbox -import Text.HTML.TagSoup - -main :: IO () -main = - Termbox.run moment - -moment :: - Event Termbox.Event -> - Behavior (Int, Int) -> - MomentIO (Behavior (Termbox.Cells, Termbox.Cursor), Event ()) -moment eEvent bSize = mdo - eTick :: Event () <- - makeTickEvent - - requestQueue :: TQueue String <- - liftIO newTQueueIO - - eSearchBox :: Event String <- - makeSearchBoxEvent eKey - - reactimate ((atomically . writeTQueue requestQueue . reverse) <$> eSearchBox) - - let eEmptySearchBox :: Event String - eEmptySearchBox = - filterE null eSearchBox - - bSearchBox :: Behavior String <- - stepper "" eSearchBox - - (eSearchResults, fireSearchResults) <- - newEvent - - liftIO . void . forkIO $ - runHttpRequestThread - requestQueue - fireSearchResults - - bSearchResults :: Behavior (Either SomeException [Value]) <- - stepper - (Right []) - ( 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 - ] - ) - - 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 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 - -makeTickEvent :: MomentIO (Event ()) -makeTickEvent = do - (e, f) <- newEvent - liftIO . void . forkIO . forever $ do - f () - threadDelay 100000 - pure e - -makeSearchBoxEvent :: - MonadMoment m => - Event Termbox.Key -> - m (Event String) -makeSearchBoxEvent eKey = - accumE - "" - ( unions - [ (:) <$> filterJust (keyAsChar <$> eKey), - (' ' :) <$ filterE (== Termbox.KeySpace) eKey, - safeTail <$ filterE (== Termbox.KeyCtrl8) eKey - ] - ) - -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 - pure $ do - respond response - loop Nothing - ) - -render :: - Int -> - String -> - Either SomeException [Value] -> - Maybe Int -> - Termbox.Cells -render height searchBox searchResults spinnerFrame = - fold - [ case searchResults of - Left ex -> - renderSearchResultsError height ex - Right results -> - renderSearchResults height results - & execWriterT - & (`evalState` 0), - renderSearchBox height searchBox spinnerFrame - ] - -renderSearchBox :: Int -> String -> Maybe Int -> Termbox.Cells -renderSearchBox height searchBox spinnerFrame = - 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) - -renderSearchResults :: - Int -> - [Value] -> - WriterT Termbox.Cells (State Int) () -renderSearchResults height = \case - [] -> - pure () - result : results -> do - row <- get - - let ss = searchResultToLines result - - 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 height ex = - ex - & show - & lines - & take height - & zip [0 ..] - & foldMap (\(row, line) -> renderString 0 row line) - -searchResultToLines :: Value -> [String] -searchResultToLines result = - case result ^?! key "type" of - "" -> - unwords - [ "[" ++ resultPackage result ++ "]", - "[" ++ resultModule result ++ "]", - resultItem result - ] - : map (" " ++) (resultDocs result) - "module" -> - unwords - [ "[" ++ resultPackage result ++ "]", - "[" ++ drop 7 (resultItem result) ++ "]" - ] - : map (" " ++) (resultDocs result) - "package" -> - ("[" ++ drop 8 (resultItem result) ++ "]") - : map (" " ++) (resultDocs result) - _ -> - error (show result) - -resultPackage :: Value -> String -resultPackage result = - result - ^?! key "package" - . key "name" - . _String - . unpacked - -resultModule :: Value -> String -resultModule result = - result - ^?! key "module" - . key "name" - . _String - . unpacked - -resultItem :: Value -> String -resultItem result = - result - ^?! key "item" - . _String - . unpacked - . to htmlToText - -resultDocs :: Value -> [String] -resultDocs result = - result - ^?! key "docs" - . _String - . unpacked - . to htmlToText - . to lines - . to collapseLines - where - collapseLines :: [String] -> [String] - collapseLines = \case - [] -> - [] - [""] -> - [] - "" : ss -> - case collapseLines ss of - "" : ts -> "" : ts - ts -> "" : ts - s : ss -> - s : collapseLines ss - -htmlToText :: String -> String -htmlToText html = - concat $ do - 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 ..] - -performHoogleSearch :: String -> IO [Value] -performHoogleSearch query = - getResponseBody <$> httpJSON (fromString searchUrl) - where - searchUrl :: String - searchUrl = - "https://hoogle.haskell.org?mode=json&count=10&hoogle=" ++ query - -eventAsKey :: Termbox.Event -> Maybe Termbox.Key -eventAsKey = \case - Termbox.EventKey k -> Just k - _ -> Nothing - -keyAsChar :: Termbox.Key -> Maybe Char -keyAsChar = \case - Termbox.KeyChar c -> Just c - _ -> Nothing - -safeTail :: [a] -> [a] -safeTail = \case - [] -> [] - _ : xs -> xs diff --git a/termbox-banana.cabal b/termbox-banana.cabal --- a/termbox-banana.cabal +++ b/termbox-banana.cabal @@ -1,32 +1,23 @@ cabal-version: 2.4 name: termbox-banana -version: 0.3.0 +version: 0.3.1 category: User Interfaces description: A @reactive-banana@-based interface to writing @termbox@ programs. . See also the package for a lower-level, imperative interface. - . - __/NOTE/__: The dependencies listed on Hackage are misleading! Most are only - used in the examples provided, which are built only if the @build-examples@ - flag is explicitly enabled. - . - The actual dependencies of the @termbox-banana@ library are only: - . - * base - * reactive-banana - * termbox synopsis: reactive-banana + termbox author: Mitchell Rosen maintainer: Mitchell Rosen homepage: https://github.com/mitchellwrosen/termbox-banana bug-reports: https://github.com/mitchellwrosen/termbox-banana/issues -copyright: (c) 2018-2020, Mitchell Rosen +copyright: (c) 2018-2022, Mitchell Rosen license: BSD-3-Clause license-file: LICENSE build-type: Simple +tested-with: GHC ==8.10.7, GHC ==9.0.2, GHC ==9.2.1 extra-source-files: CHANGELOG.md @@ -36,17 +27,17 @@ type: git location: git://github.com/mitchellwrosen/termbox-banana.git -flag build-examples - description: Build example executables - default: False - manual: True - -common component +library + build-depends: + base ^>= 4.10 || ^>= 4.11 || ^>= 4.12 || ^>= 4.13 || ^>= 4.14 || ^>= 4.15 || ^>= 4.16, + reactive-banana ^>= 1.2 || ^>= 1.3, + termbox ^>= 0.3, default-extensions: GeneralizedNewtypeDeriving InstanceSigs LambdaCase default-language: Haskell2010 + exposed-modules: Termbox.Banana ghc-options: -Weverything -Wno-implicit-prelude @@ -59,43 +50,4 @@ ghc-options: -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module - -common example-executable - import: component - if !flag(build-examples) - buildable: False - build-depends: - base, - reactive-banana, - termbox-banana, - ghc-options: -Wall -threaded "-with-rtsopts=-N" - 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 - -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, - http-conduit, - lens, - lens-aeson, - mtl, - stm, - tagsoup, - main-is: Hoogle.hs