diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -4,7 +4,7 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.3.20190418 +# version: 0.3.20190521 # language: c dist: xenial @@ -26,12 +26,10 @@ - rm -rfv $CABALHOME/packages/head.hackage matrix: include: - - compiler: ghc-8.6.4 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.4","cabal-install-2.4"]}} + - 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"]}} - - compiler: ghc-8.2.2 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}} before_install: - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - HCPKG="$HC-pkg" @@ -77,6 +75,7 @@ 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 @@ -93,7 +92,7 @@ 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)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - "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 @@ -117,7 +116,7 @@ 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)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - "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... 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.2.0] - 2019-06-28 + +### Added +- Added `run` + +### Changed +- Renamed `main` to `run_` +- Bumped `termbox` lower bound + ## [0.1.1] - 2019-04-19 ### Changed diff --git a/examples/Echo.hs b/examples/Echo.hs new file mode 100644 --- /dev/null +++ b/examples/Echo.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module 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 + +moment + :: Event Termbox.Event + -> Behavior (Int, Int) + -> MomentIO (Behavior Termbox.Scene, 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.Scene + bScene = + Termbox.Scene + <$> 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 new file mode 100644 --- /dev/null +++ b/examples/Hoogle.hs @@ -0,0 +1,350 @@ +{-# 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 Text.HTML.TagSoup + +import qualified Termbox.Banana as Termbox + +main :: IO () +main = + Termbox.run_ + (Termbox.InputModeEsc Termbox.MouseModeNo) + Termbox.OutputModeNormal + moment + +moment + :: Event Termbox.Event + -> Behavior (Int, Int) + -> MomentIO (Behavior Termbox.Scene, 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.Scene + bScene = + Termbox.Scene + <$> 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.KeyBackspace2) eKey + ]) + +runHttpRequestThread + :: TQueue String -- ^ Request queue + -> (Either SomeException [Value] -> IO ()) -- ^ Response callback + -> 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/src/Termbox/Banana.hs b/src/Termbox/Banana.hs --- a/src/Termbox/Banana.hs +++ b/src/Termbox/Banana.hs @@ -1,4 +1,4 @@ -{-# language CPP #-} +{-# language DerivingStrategies #-} {-# language GeneralizedNewtypeDeriving #-} {-# language LambdaCase #-} {-# language ScopedTypeVariables #-} @@ -6,12 +6,12 @@ module Termbox.Banana ( -- $intro - TermboxEvent - , main + , run + , run_ + , set , Scene(..) , Cells - , set , Cursor(..) -- * Re-exports , Termbox.black @@ -34,16 +34,29 @@ , Termbox.Mouse(..) , Termbox.MouseMode(..) , Termbox.OutputMode(..) + -- * Example + -- $example ) 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. -- -- @ @@ -73,15 +86,7 @@ -- @since 0.1.0 newtype Cells = Cells (IO ()) -#if MIN_VERSION_base(4,10,0) - deriving (Monoid, Semigroup) -#else -instance Monoid Cells where - mempty = Cells (pure ()) - mappend = (<>) -instance Semigroup Cells where - Cells x <> Cells y = Cells (x >> y) -#endif + deriving newtype (Monoid, Semigroup) -- | A cursor. -- @@ -113,16 +118,16 @@ -- * 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.1.0 -main +-- @since 0.2.0 +run :: Termbox.InputMode -- ^ -> Termbox.OutputMode -- ^ -> ( Event TermboxEvent -> Behavior (Int, Int) -> MomentIO (Behavior Scene, Event a)) - -> IO a -main imode omode run = - Termbox.main $ do + -> IO (Either Termbox.InitError a) +run imode omode program = + Termbox.run $ do Termbox.setInputMode imode Termbox.setOutputMode omode @@ -146,11 +151,11 @@ _ -> Nothing) <$> eEvent) - bSize :: Behavior (Int, Int) <- do + bSize :: Behavior (Int, Int) <- flip stepper eResize =<< - liftIO Termbox.size + liftIO Termbox.getSize - moment run eEvent bSize (putMVar doneVar) + moment program eEvent bSize (putMVar doneVar) actuate network @@ -159,6 +164,19 @@ 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 + moment :: ( Event TermboxEvent -> Behavior (Int, Int) @@ -167,9 +185,9 @@ -> Behavior (Int, Int) -> (a -> IO ()) -> MomentIO () -moment run eEvent bSize abort = do +moment program eEvent bSize abort = do (bScene, eDone) :: (Behavior Scene, Event a) <- - run eEvent bSize + program eEvent bSize eScene :: Event (Future Scene) <- changes bScene @@ -187,3 +205,67 @@ liftIO . render =<< valueB bScene reactimate (abort <$> eDone) reactimate' ((fmap.fmap) render eScene) + +-- $example +-- +-- Below is a sample program that simply displays the last key pressed, and +-- quits on @Esc@: +-- +-- @ +-- {-\# LANGUAGE LambdaCase \#-} +-- {-\# LANGUAGE ScopedTypeVariables \#-} +-- +-- module Main where +-- +-- import Reactive.Banana +-- import Reactive.Banana.Frameworks +-- +-- import qualified Termbox.Banana as Termbox +-- +-- main :: IO () +-- main = +-- Termbox.'run_' +-- (Termbox.'Termbox.InputModeEsc' Termbox.'Termbox.MouseModeNo') +-- Termbox.'Termbox.OutputModeNormal' +-- moment +-- +-- moment +-- :: Event Termbox.'Termbox.Event' +-- -> Behavior (Int, Int) +-- -> MomentIO (Behavior Termbox.'Termbox.Scene', Event ()) +-- moment eEvent _bSize = do +-- let +-- eQuit :: Event () +-- eQuit = +-- () <$ filterE isKeyEsc eEvent +-- +-- bLatestEvent :: Behavior (Maybe Termbox.'Termbox.Event') <- +-- stepper +-- Nothing +-- (Just \<$\> eEvent) +-- +-- let +-- bCells :: Behavior Termbox.'Termbox.Cells' +-- bCells = +-- maybe mempty renderEvent \<$\> bLatestEvent +-- +-- let +-- bScene :: Behavior Termbox.'Termbox.Scene' +-- bScene = +-- Termbox.'Termbox.Scene' +-- \<$\> bCells +-- \<*\> pure Termbox.'Termbox.NoCursor' +-- +-- pure (bScene, eQuit) +-- +-- renderEvent :: Termbox.'Termbox.Event' -> Termbox.'Termbox.Cells' +-- renderEvent = +-- foldMap (\\(i, c) -> Termbox.set i 0 (Termbox.'Termbox.Cell' c mempty mempty)) +-- . zip [0..] +-- . show +-- +-- isKeyEsc :: Termbox.'Termbox.Event' -> Bool +-- isKeyEsc = \\case +-- Termbox.'Termbox.EventKey' Termbox.'Termbox.KeyEsc' _ -> True +-- _ -> False +-- @ diff --git a/termbox-banana.cabal b/termbox-banana.cabal --- a/termbox-banana.cabal +++ b/termbox-banana.cabal @@ -1,51 +1,121 @@ -cabal-version: 2.0 +cabal-version: 2.4 name: termbox-banana -version: 0.1.1 +version: 0.2.0 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, Mitchell Rosen -license: BSD3 +copyright: (c) 2018-2019, Mitchell Rosen +license: BSD-3-Clause license-file: LICENSE build-type: Simple -tested-with: GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.4 +tested-with: GHC == 8.4.4, GHC == 8.6.5 extra-source-files: .travis.yml CHANGELOG.md README.md +flag build-examples + description: Build example executables + default: False + manual: True + library build-depends: - base ^>= 4.9 || ^>= 4.10 || ^>= 4.11 || ^>= 4.12 + base ^>= 4.10 || ^>= 4.11 || ^>= 4.12 , reactive-banana ^>= 1.2 - , termbox ^>= 0.1 + , termbox ^>= 0.2 + default-language: Haskell2010 + exposed-modules: Termbox.Banana + ghc-options: - -fprint-expanded-synonyms - -fprint-explicit-foralls - -fprint-explicit-kinds - -fprint-unicode-syntax -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns + -Wmissing-export-lists -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + -Wpartial-fields -Wredundant-constraints - if impl(ghc >= 8.4) - ghc-options: - -Wmissing-export-lists - -Wpartial-fields + -fprint-expanded-synonyms + -fprint-explicit-foralls + -fprint-explicit-kinds + -fprint-unicode-syntax + hs-source-dirs: src + +executable termbox-banana-example-echo + if !flag(build-examples) + buildable: False + + build-depends: + base, + reactive-banana, + termbox-banana, + + default-language: + Haskell2010 + + ghc-options: + -Wall -threaded "-with-rtsopts=-N" + + hs-source-dirs: + examples + + main-is: + Echo.hs + +executable termbox-banana-example-hoogle + 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