tkhs (empty) → 0.1.0.0
raw patch · 10 files changed
+543/−0 lines, 10 filesdep +HUnitdep +basedep +mtlbuild-type:Customsetup-changed
Dependencies added: HUnit, base, mtl, parsec, pointedlist, pretty, test-framework, test-framework-hunit, utf8-string, vty
Files
- LICENSE +31/−0
- README +51/−0
- Setup.lhs +10/−0
- demo/demo.txt +15/−0
- src/Main.hs +34/−0
- src/Parser.hs +49/−0
- src/Tkhs.hs +108/−0
- src/Vty.hs +171/−0
- test/Test.hs +21/−0
- tkhs.cabal +53/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright Yusaku Hashimoto 2009++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Yusaku Hashimoto nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ README view
@@ -0,0 +1,51 @@+=+Simple+Presentaion+Utility++tkhs+-+Usage+-+tkhs slide.txt+-+Try+tkhs README (this file)+-+Control+-+Using Keyboard+-+Keybind+=+N for next slide+P for previous slide+Q for quit+-+Format of+presentaion file+-+See This File+-+Centered style (-)+Preformatted style (=)+-+are (and only)+Avaliable+-+That's all+-+Any Feedbacks are+Appreciated+-+tkhs is inspired by+hspresent+-+Try also+cabal install hspresent+-+Thanks+-+Especially Thanks to+Evan, author of hspresent+=
+ Setup.lhs view
@@ -0,0 +1,10 @@+#!/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"
+ demo/demo.txt view
@@ -0,0 +1,15 @@+=+The+Title of Presentation+++Author+-+The first slide+-+The second slide+-+The third slide+-+The End+=
+ src/Main.hs view
@@ -0,0 +1,34 @@+module Main where++import Tkhs+import Parser++import System.Environment+import System.IO.UTF8 as U+import Codec.Binary.UTF8.String+import Data.Char++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++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
@@ -0,0 +1,49 @@+{-# OPTIONS_GHC -fglasgow-exts -XNoMonomorphismRestriction #-}+{-# OPTIONS_GHC -XPackageImports #-}++module Parser (parseSlides) where++import Tkhs++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++type PC a = ParsecT String () Identity a++t_sig, f_sig, any_sig :: PC ()+t_sig = char '-' >> newline >> return ()+f_sig = char '=' >> newline >> return ()+any_sig = choice [t_sig,f_sig]++t :: PC Slide+t = do+ t_sig+ T <$> lines++f :: PC Slide+f = do+ f_sig+ F <$> lines++lines :: PC [String]+lines = line `manyTill` (lookAhead (any_sig <|> eof))++slide :: PC Slide+slide = try t <|> try f <?> "slide"++line :: PC String+line = noneOf "\r\n" `manyTill` try newline++newline :: PC String+newline = try (string "\r\n")+ <|> try (string "\n")+ <|> try (string "\r")+ <?> "newline"
+ src/Tkhs.hs view
@@ -0,0 +1,108 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++module Tkhs (+-- * P Monad (Presentation with Vty)+ P (..), runP, liftV++-- ** Presentaion loop+, presentation++-- * Slides+, Slide (..), SlideSet, PictureSet++-- * Zipper+, Zipper+)where++import Vty++import qualified Data.List.PointedList as Zipper+import Data.List.PointedList (PointedList)+import Control.Applicative hiding ((<|>))+import Control.Monad.State+import Control.Monad.Reader+import qualified Data.Traversable as T+import qualified Data.Foldable as F+import System.IO+import System.Exit+import Text.PrettyPrint hiding (render)++type Zipper a = PointedList a++data Slide = T [String] | F [String]+type SlideSet = Zipper Slide+type PictureSet = Zipper Picture++newtype P a = P { unP :: StateT PictureSet V a }+ deriving (Functor, Monad, MonadState PictureSet)++slideToImage :: Slide -> Image+slideToImage (T ls) = processBy (flip centeringBy 1) ls+slideToImage (F ls) = processBy ljust ls+ where ljust maxlen img = let orig_width = imgWidth img+ in img <|> render (replicate (maxlen - 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++-- slideSetToPictureSet :: SlideSet -> V PictureSet+-- slideSetToPictureSet = T.mapM $ fmap toPic+-- . centering+-- . slideToImage++runP :: P a -> SlideSet -> IO a+runP (P st) slides = runVty $ do+ ourVty <- ask+ 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+ mapM_ warn [ "To drawing this presentation, at least "+ ++ show maxWidth ++ "x" ++ show maxHeight+ ++ " size is needed."+ , "Press any key to exit, and try bigger terminal. Sorry." ]+ liftIO =<< waitOnce exitFailure (return undefined)+ pictures <- T.mapM (fmap toPic . centering) imgset+ evalStateT st pictures `withVty` ourVty++warn :: String -> V ()+warn str = do+ w <- width+ liftIO . hPutStrLn stderr+ . renderStyle style { lineLength = w, ribbonsPerLine = 1.0 }+ . fsep . map text . words $ str++liftV :: V a -> P a+liftV = P . lift++presentation :: P ()+presentation = do+ current <- Zipper.focus <$> get+ liftV clear+ liftV . draw $ current+ control++control :: P ()+control = id =<< dispatch+ where dispatch = liftV . waitBy $ do+ onKey (ascii 'n') $ loopBy goNext+ onKey kright $ loopBy goNext+ onKey (ascii 'p') $ loopBy goPrev+ onKey kleft $ loopBy goPrev+ onKey (ascii 'q') quit+ loopBy = (>> presentation)++goNext :: P ()+goNext = modify (\s -> maybe s id (Zipper.next s))++goPrev :: P ()+goPrev = modify (\s -> maybe s id (Zipper.previous s))++quit :: P ()+quit = return ()++withVty :: V a -> Vty -> V a+withVty (V v) vty = liftIO $ runReaderT v vty
+ src/Vty.hs view
@@ -0,0 +1,171 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++module Vty (+-- * V Monad (Vty actions wrapper)+ V (..), runVty++-- ** Accessing Vty+, event, draw, clear+, size, width, height++-- ** Utilities along V+, centering, doesFit++-- * D Monad (Event Dispatcher Combinators)+, D (..), KeyEvent (..), Dispatcher, toTable, toEvent++-- ** Event and Dispatch Combinators+, onKey, modifiedBy+, waitBy, waitOnce++-- ** Key values working with our types and Synonims for some Modifiers+, ascii, kleft, kup, kdown, kright+, mctrl, malt, mshift++-- ** Lower level interface+, addDispatcher++-- * Utilities+, toPic, render, centeringBy, Width, Height+, doesFitBy++, module Graphics.Vty+) where++import Graphics.Vty+import Control.Applicative hiding ((<|>))+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Exception+-- 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)++type Dispatcher r = (Event, r)+newtype D r a = D { unD :: Writer [Dispatcher r] a }+ deriving (Functor, Monad, MonadWriter [Dispatcher r])++runVty :: V a -> IO a+runVty (V v) = do+ vty <- mkVty+ a <- runReaderT v vty `finally` shutdown vty+ return a++event :: V Event+event = ask >>= liftIO . getEvent++draw :: Picture -> V ()+draw p = ask >>= liftIO . flip update p++clear :: V ()+clear = ask >>= liftIO . refresh++type Width = Int+type Height = Int++size :: V (Width,Height)+size = ask >>= liftIO . getSize++width :: V Width+width = fst <$> size++height :: V Height+height = snd <$> size++centering :: Image -> V Image+centering image = do+ (w,h) <- size+ let imgW = imgWidth image+ newImg = if imgW > w+ then image+ else centeringBy w h image+ return newImg++doesFit :: Image -> V Bool+doesFit img = do+ (w,h) <- size+ return . doesFitBy w h $ img++addDispatcher :: Dispatcher r -> D r ()+addDispatcher = tell . (:[])++newtype KeyEvent = KE { unKE :: (Key,[Modifier]) }++onKey :: KeyEvent -> r -> D r ()+onKey ke r = addDispatcher (toEvent ke,r)++toEvent :: KeyEvent -> Event+toEvent = uncurry EvKey . unKE++asKeyEvent :: Key -> KeyEvent+asKeyEvent k = KE (k,[])++ascii :: Char -> KeyEvent+ascii c = asKeyEvent . KASCII $ c++modifiedBy :: KeyEvent -> Modifier -> KeyEvent+modifiedBy (KE (k,ms)) m = KE (k,m:ms)++kleft, kright, kup, kdown :: KeyEvent+kleft = asKeyEvent KLeft+kright = asKeyEvent KRight+kup = asKeyEvent KUp+kdown = asKeyEvent KDown++mshift, mctrl, malt :: Modifier+mshift = MShift+mctrl = MCtrl+malt = MAlt++toTable :: D r a -> [(Event,r)]+toTable = execWriter . unD++waitBy :: D r a -> V r+waitBy d = do+ evt <- event+ case tryDispatch evt table of+ Just r -> return r+ Nothing -> waitBy d+ where table = toTable d+ tryDispatch = lookup++waitOnce :: r -> D r a -> V r+waitOnce r d = do+ evt <- event+ return . maybe r id . lookup evt $ toTable d++toPic :: Image -> Picture+toPic img = pic { pImage = img }++render :: String -> Image+-- render str = let bs = U.pack str+-- in renderBS attr bs+render = horzcat . map (renderChar attr)++centeringBy :: Width -> Height -> Image -> Image+centeringBy wholeWidth wholeHeight img+ | wholeWidth < imgWidth img || wholeHeight < imgHeight img = img+ | otherwise = let imgW = imgWidth img+ imgH = imgHeight 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 ' '+ in spacebox lpad wholeHeight+ <|>+ (spacebox imgW tpad+ <-> img+ <-> spacebox imgW bpad)+ <|>+ spacebox rpad wholeHeight++doesFitBy :: Width -> Height -> Image -> Bool+doesFitBy w h img = w >= imgWidth img && h >= imgHeight img+
+ test/Test.hs view
@@ -0,0 +1,21 @@+import Vty++import Test.Framework (defaultMain, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.API (Test)+import Test.HUnit (Assertable(..))++main = defaultMain [+ testGroup "doesFitBy" [+ "returns True if an image seemed to fit" ~~+ doesFitBy 100 100 (render "foo")+ ,"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+ in doesFitBy w h img+ ]+ ]++(~~) :: (Assertable a) => String -> a -> Test+testname ~~ assertion = testCase testname . assert $ assertion
+ tkhs.cabal view
@@ -0,0 +1,53 @@+name: tkhs+version: 0.1.0.0+synopsis: Simple Presentaion Utility+description: If you want to do your presentation by terminal,+ or your slide is too simple to make with Powerpoint,+ or such softwares, It may be useful.+category: Graphics+license: BSD3+license-file: LICENSE+extra-source-files: README, demo/demo.txt+author: Yusaku Hashimoto+maintainer: Yusaku Hashimoto <nonowarn@gmail.com>+build-type: Custom+cabal-version: >= 1.6+stability: experimental+homepage: http://patch-tag.com/r/tkhs/snapshot/current/content/pretty/README++flag test+ description: Build test program.+ default: False++Executable tkhs+ hs-source-dirs: src+ executable: tkhs+ main-is: Main.hs+ ghc-options: -Wall+ build-depends: base == 4.*+ , pointedlist+ , mtl+ , vty+ , parsec == 3.*+ , pretty+ , utf8-string+ other-modules: Vty+ Tkhs+ Parser+ if flag(test)+ buildable: False++Executable test+ hs-source-dirs: src, test+ other-modules:+ main-is: Test.hs+ build-depends: test-framework+ , test-framework-hunit+ , HUnit+ ghc-options: -fglasgow-exts+ if !flag(test)+ buildable: False++Source-repository head+ type: darcs+ location: http://patch-tag.com/r/tkhs/pullrepo