diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -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 diff --git a/src/Tkhs.hs b/src/Tkhs.hs --- a/src/Tkhs.hs +++ b/src/Tkhs.hs @@ -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." diff --git a/src/Vty.hs b/src/Vty.hs --- a/src/Vty.hs +++ b/src/Vty.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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 ] ] diff --git a/tkhs.cabal b/tkhs.cabal --- a/tkhs.cabal +++ b/tkhs.cabal @@ -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 -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