termbox-banana 0.1.1 → 0.2.0

raw patch · 6 files changed

+611/−45 lines, 6 filesdep +aesondep +asyncdep +http-conduitdep ~basedep ~reactive-bananadep ~termboxnew-component:exe:termbox-banana-example-echonew-component:exe:termbox-banana-example-hooglePVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, async, http-conduit, lens, lens-aeson, mtl, stm, tagsoup, termbox-banana

Dependency ranges changed: base, reactive-banana, termbox

API changes (from Hackage documentation)

Files

• .travis.yml +6/−7
• CHANGELOG.md +9/−0
• examples/Echo.hs +56/−0
• examples/Hoogle.hs +350/−0
• src/Termbox/Banana.hs +105/−23
• termbox-banana.cabal +85/−15

@@ -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...

@@ -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

@@ -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

@@ -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

@@ -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+-- @

@@ -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 <https://hackage.haskell.org/termbox termbox> 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 <mitchellwrosen@gmail.com> 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