tkhs 0.2.4 → 0.3.0
raw patch · 5 files changed
+44/−58 lines, 5 filesdep ~parsecdep ~vtysetup-changed
Dependency ranges changed: parsec, vty
Files
- Setup.lhs +1/−8
- src/Tkhs.hs +8/−8
- src/Vty.hs +22/−27
- test/Test.hs +1/−1
- tkhs.cabal +12/−14
Setup.lhs view
@@ -1,10 +1,3 @@ #!/usr/bin/env runhaskell > import Distribution.Simple-> import Distribution.Simple.LocalBuildInfo-> import System.FilePath ((</>))-> import System.Cmd (system)->-> main = defaultMainWithHooks simpleUserHooks { runTests = runTests' }->-> runTests' _ _ _ lbi = system testprog >> return ()-> where testprog = buildDir lbi </> "test" </> "test"+> main = defaultMainWithHooks
src/Tkhs.hs view
@@ -14,7 +14,7 @@ , Zipper )where -import Vty+import Vty hiding (text) import qualified Zipper import Zipper (Zipper)@@ -32,18 +32,18 @@ type PictureSet = Zipper Picture newtype P a = P { unP :: StateT PictureSet V a }- deriving (Functor, Monad, MonadState PictureSet)+ deriving (Functor, Applicative, Monad, MonadState PictureSet) slideToImage :: Slide -> Image slideToImage (T ls) = processBy (flip centeringBy 1 . fromIntegral) ls slideToImage (F ls) = processBy ljust ls- where ljust maxlen img = let orig_width = image_width img- in img <|> render (replicate (maxlen - fromIntegral orig_width) ' ')+ where ljust maxlen img = let origWidth = imageWidth img+ in img <|> render (replicate (maxlen - fromIntegral origWidth) ' ') processBy :: (Int -> Image -> Image) -> [String] -> Image processBy f ls = let imgs = map render ls- maxlen = fromIntegral . maximum $ map image_width imgs- in vert_cat . map (f maxlen) $ imgs+ maxlen = fromIntegral . maximum $ map imageWidth imgs+ in vertCat . map (f maxlen) $ imgs -- slideSetToPictureSet :: SlideSet -> V PictureSet -- slideSetToPictureSet = T.mapM $ fmap toPic@@ -56,8 +56,8 @@ let imgset = fmap slideToImage slides check <- F.and <$> T.mapM doesFit imgset when (not check) $ do- let maxWidth = F.maximum $ fmap image_width imgset- maxHeight = F.maximum $ fmap image_height imgset+ let maxWidth = F.maximum $ fmap imageWidth imgset+ maxHeight = F.maximum $ fmap imageHeight imgset mapM_ warn [ "To display this presentation, the terminal must be at least " ++ show maxWidth ++ "x" ++ show maxHeight ++ "." , "Please try again with a bigger terminal."
src/Vty.hs view
@@ -37,25 +37,24 @@ import Control.Monad.Reader import Control.Monad.Writer import Control.Exception-import Data.Word -- import Codec.Binary.UTF8.String -- import qualified Data.ByteString.UTF8 as U newtype V a = V { unV :: ReaderT Vty IO a }- deriving (Functor, Monad, MonadIO, MonadReader Vty)+ deriving (Functor, Applicative, Monad, MonadIO, MonadReader Vty) type Dispatcher r = (Event, r) newtype D r a = D { unD :: Writer [Dispatcher r] a }- deriving (Functor, Monad, MonadWriter [Dispatcher r])+ deriving (Functor, Applicative, Monad, MonadWriter [Dispatcher r]) runVty :: V a -> IO a runVty (V v) = do- vty <- mkVty+ vty <- mkVty =<< userConfig a <- runReaderT v vty `finally` shutdown vty return a event :: V Event-event = ask >>= liftIO . next_event+event = ask >>= liftIO . nextEvent draw :: Picture -> V () draw p = ask >>= liftIO . flip update p@@ -63,13 +62,13 @@ clear :: V () clear = ask >>= liftIO . refresh -type Width = Word-type Height = Word+type Width = Int+type Height = Int size :: V (Width,Height) size = do- term <- terminal <$> ask- DisplayRegion w h <- liftIO $ display_bounds term+ output <- asks outputIface+ (w, h) <- liftIO $ displayBounds output return (w,h) width :: V Width@@ -81,7 +80,7 @@ centering :: Image -> V Image centering image = do (w,h) <- size- let imgW = image_width image+ let imgW = imageWidth image newImg = if imgW > w then image else centeringBy w h image@@ -107,7 +106,7 @@ asKeyEvent k = KE (k,[]) ascii :: Char -> KeyEvent-ascii c = asKeyEvent . KASCII $ c+ascii c = asKeyEvent . KChar $ c modifiedBy :: KeyEvent -> Modifier -> KeyEvent modifiedBy (KE (k,ms)) m = KE (k,m:ms)@@ -141,38 +140,34 @@ return . maybe r id . lookup evt $ toTable d toPic :: Image -> Picture-toPic img = pic_for_image img+toPic img = picForImage img render :: String -> Image -- render str = let bs = U.pack str -- in renderBS attr bs-render = horiz_cat . map (char def_attr)--toInt :: Word -> Int-toInt = fromIntegral+render = horizCat . map (char defAttr) centeringBy :: Width -> Height -> Image -> Image centeringBy wholeWidth wholeHeight img- | wholeWidth < image_width img || wholeHeight < image_height img = img- | otherwise = let imgW = image_width img- imgH = image_height img+ | wholeWidth < imageWidth img || wholeHeight < imageHeight img = img+ | otherwise = let imgW = imageWidth img+ imgH = imageHeight img magW = wholeWidth - imgW magH = wholeHeight - imgH lpad = magW `div` 2 rpad = magW `div` 2 + magW `mod` 2 tpad = magH `div` 2 bpad = magH `div` 2 + magH `mod` 2- spacebox w h = vert_cat- . replicate (toInt h)- . render $ replicate (toInt w) ' '+ spacebox w h = vertCat+ . replicate h+ . render $ replicate w ' ' in spacebox lpad wholeHeight <|>- (spacebox imgW tpad- <-> img- <-> spacebox imgW bpad)+ ( spacebox imgW tpad+ <-> img+ <-> spacebox imgW bpad ) <|> spacebox rpad wholeHeight doesFitBy :: Width -> Height -> Image -> Bool-doesFitBy w h img = w >= image_width img && h >= image_height img-+doesFitBy w h img = w >= imageWidth img && h >= imageHeight img
test/Test.hs view
@@ -12,7 +12,7 @@ ,"returns False unless an image seemed to fit" ~~ not (doesFitBy 0 0 (render "foo")) ,"returns True if width and height is equal to image's width height" ~~- let img = render "foo"; w = imgWidth img; h = imgHeight img+ let img = render "foo"; w = imageWidth img; h = imageHeight img in doesFitBy w h img ] ]
tkhs.cabal view
@@ -1,5 +1,5 @@ name: tkhs-version: 0.2.4+version: 0.3.0 synopsis: Simple Presentation Utility description: If you want to give your presentation in a terminal, or if PowerPoint would be overkill, you may find tkhs useful.@@ -9,8 +9,8 @@ extra-source-files: README, demo/demo.txt author: Yusaku Hashimoto maintainer: Yusaku Hashimoto <nonowarn@gmail.com>-build-type: Custom-cabal-version: >= 1.6+build-type: Simple+cabal-version: >= 1.8 stability: experimental homepage: http://patch-tag.com/r/nonowarn/tkhs/snapshot/current/content/pretty/README @@ -21,11 +21,11 @@ Executable tkhs hs-source-dirs: src main-is: Main.hs- ghc-options: -Wall- build-depends: base == 4.*+ ghc-options: -Wall -threaded+ build-depends: base == 4.* , mtl- , vty == 4.6.*- , parsec == 2.*+ , vty == 5.*+ , parsec , pretty , utf8-string other-modules: Vty@@ -35,16 +35,14 @@ if flag(test) buildable: False -Executable test+Test-Suite test-tkhs+ type: exitcode-stdio-1.0 hs-source-dirs: src, test other-modules: main-is: Test.hs- if !flag(test)- buildable: False- else- build-depends: test-framework- , test-framework-hunit- , HUnit+ build-depends: test-framework+ , test-framework-hunit+ , HUnit Source-repository head