tkhs 0.1.0.6 → 0.2.1
raw patch · 5 files changed
+40/−51 lines, 5 filesdep ~vty
Dependency ranges changed: vty
Files
- src/Main.hs +5/−19
- src/Parser.hs +2/−5
- src/Tkhs.hs +10/−11
- src/Vty.hs +21/−14
- tkhs.cabal +2/−2
src/Main.hs view
@@ -5,30 +5,16 @@ import System.Environment import System.IO.UTF8 as U-import Codec.Binary.UTF8.String import Data.Char+import qualified Data.List.PointedList as Zipper+import Data.Maybe main :: IO () main = getArgs >>= U.readFile . headOrUsage- >>= either (error . show) (runP presentation) . preprocess- -- vty recognizes any charactor has 1 half-width- -- thus for non-ascii full-width byte char,- -- for displaying string at center, some tuning is needed.- -- concretely, 1 half-width is ignored by 1 full-width char,- -- thus ignored width is added by adding spaces.- where preprocess = parseSlides . unlines . map processWideChars . lines+ >>= either (error . show)+ (runP presentation . fromJust . Zipper.fromList . (++[T ["[End of Slide]"]]))+ . parseSlides headOrUsage :: [String] -> String headOrUsage ls | null ls = error "Usage: tkhs [presentation]" | otherwise = head ls--processWideChars :: String -> String-processWideChars str = let wideChars = length . filter (not . isHalfWidth) $ str- in str ++ replicate wideChars ' '---- Table of Half-width Kana--- http://ash.jp/code/unitbl1.htm-isHalfWidth :: Char -> Bool-isHalfWidth c = isLatin1 c || c `elem` [h .. t]- where h = head . decodeString $ "\xef\xbd\xa1" -- minimum of half-kana- t = head . decodeString $ "\xef\xbe\x9f" -- maximum of half-kana
src/Parser.hs view
@@ -1,5 +1,4 @@ {-# OPTIONS_GHC -fglasgow-exts -XNoMonomorphismRestriction #-}-{-# OPTIONS_GHC -XPackageImports #-} module Parser (parseSlides) where @@ -8,13 +7,11 @@ import Text.Parsec hiding (newline, (<|>)) import Control.Monad.Identity import Control.Applicative hiding (many)-import Data.Maybe-import Data.List.PointedList as Zipper import Prelude hiding (lines) -parseSlides :: String -> Either ParseError SlideSet-parseSlides str = parse (fromJust . Zipper.fromList <$> many1 slide) "" str+parseSlides :: String -> Either ParseError [Slide]+parseSlides str = parse (many1 slide) "" str type PC a = ParsecT String () Identity a
src/Tkhs.hs view
@@ -14,7 +14,7 @@ , Zipper )where -import Vty+import Vty hiding (style) import qualified Data.List.PointedList as Zipper import Data.List.PointedList (PointedList)@@ -37,15 +37,15 @@ deriving (Functor, Monad, MonadState PictureSet) slideToImage :: Slide -> Image-slideToImage (T ls) = processBy (flip centeringBy 1) ls+slideToImage (T ls) = processBy (flip centeringBy 1 . fromIntegral) ls slideToImage (F ls) = processBy ljust ls- where ljust maxlen img = let orig_width = imgWidth img- in img <|> render (replicate (maxlen - orig_width) ' ')+ where ljust maxlen img = let orig_width = image_width img+ in img <|> render (replicate (maxlen - fromIntegral orig_width) ' ') processBy :: (Int -> Image -> Image) -> [String] -> Image processBy f ls = let imgs = map render ls- maxlen = maximum $ map imgWidth imgs- in vertcat . map (f maxlen) $ imgs+ maxlen = fromIntegral . maximum $ map image_width imgs+ in vert_cat . map (f maxlen) $ imgs -- slideSetToPictureSet :: SlideSet -> V PictureSet -- slideSetToPictureSet = T.mapM $ fmap toPic@@ -58,13 +58,13 @@ let imgset = fmap slideToImage slides check <- F.and <$> T.mapM doesFit imgset when (not check) $ do- let maxWidth = F.maximum $ fmap imgWidth imgset- maxHeight = F.maximum $ fmap imgHeight imgset+ let maxWidth = F.maximum $ fmap image_width imgset+ maxHeight = F.maximum $ fmap image_height 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." , "Press any key to exit." ]- liftIO =<< waitOnce exitFailure (return undefined)+ liftIO =<< waitOnce exitFailure (return ()) pictures <- T.mapM (fmap toPic . centering) imgset evalStateT st pictures `withVty` ourVty @@ -72,7 +72,7 @@ warn str = do w <- width liftIO . hPutStrLn stderr- . renderStyle style { lineLength = w, ribbonsPerLine = 1.0 }+ . renderStyle style { lineLength = fromIntegral w, ribbonsPerLine = 1.0 } . fsep . map text . words $ str liftV :: V a -> P a@@ -81,7 +81,6 @@ presentation :: P () presentation = do current <- Zipper.focus <$> get- liftV clear liftV . draw $ current control
src/Vty.hs view
@@ -37,6 +37,7 @@ 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 @@ -54,7 +55,7 @@ return a event :: V Event-event = ask >>= liftIO . getEvent+event = ask >>= liftIO . next_event draw :: Picture -> V () draw p = ask >>= liftIO . flip update p@@ -62,11 +63,14 @@ clear :: V () clear = ask >>= liftIO . refresh -type Width = Int-type Height = Int+type Width = Word+type Height = Word size :: V (Width,Height)-size = ask >>= liftIO . getSize+size = do+ term <- terminal <$> ask+ DisplayRegion w h <- liftIO $ display_bounds term+ return (w,h) width :: V Width width = fst <$> size@@ -77,7 +81,7 @@ centering :: Image -> V Image centering image = do (w,h) <- size- let imgW = imgWidth image+ let imgW = image_width image newImg = if imgW > w then image else centeringBy w h image@@ -137,27 +141,30 @@ return . maybe r id . lookup evt $ toTable d toPic :: Image -> Picture-toPic img = pic { pImage = img }+toPic img = pic_for_image img render :: String -> Image -- render str = let bs = U.pack str -- in renderBS attr bs-render = horzcat . map (renderChar attr)+render = horiz_cat . map (char def_attr) +toInt :: Word -> Int+toInt = fromIntegral+ centeringBy :: Width -> Height -> Image -> Image centeringBy wholeWidth wholeHeight img- | wholeWidth < imgWidth img || wholeHeight < imgHeight img = img- | otherwise = let imgW = imgWidth img- imgH = imgHeight img+ | wholeWidth < image_width img || wholeHeight < image_height img = img+ | otherwise = let imgW = image_width img+ imgH = image_height 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 = vertcat- . replicate h- . render $ replicate w ' '+ spacebox w h = vert_cat+ . replicate (toInt h)+ . render $ replicate (toInt w) ' ' in spacebox lpad wholeHeight <|> (spacebox imgW tpad@@ -167,5 +174,5 @@ spacebox rpad wholeHeight doesFitBy :: Width -> Height -> Image -> Bool-doesFitBy w h img = w >= imgWidth img && h >= imgHeight img+doesFitBy w h img = w >= image_width img && h >= image_height img
tkhs.cabal view
@@ -1,5 +1,5 @@ name: tkhs-version: 0.1.0.6+version: 0.2.1 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.@@ -26,7 +26,7 @@ build-depends: base == 4.* , pointedlist , mtl- , vty == 3.*+ , vty == 4.* , parsec == 3.* , pretty , utf8-string