Created
January 16, 2013 23:14
hoodle start.hs script example
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE RecordWildCards, DeriveDataTypeable, ScopedTypeVariables #-} | |
module Main where | |
import Control.Category | |
import Control.Lens hiding ((<.>)) | |
import qualified Data.ByteString.Char8 as B | |
import Data.Monoid | |
import Data.Time.Clock | |
import Graphics.Rendering.Cairo | |
import Graphics.UI.Gtk hiding (get,set) | |
import System.Directory | |
import System.FilePath | |
-- | |
import Data.Hoodle.BBox | |
import Data.Hoodle.Simple | |
import Graphics.Hoodle.Render | |
import Graphics.Hoodle.Render.Item | |
import Hoodle.Script | |
import Hoodle.Script.Hook | |
import Hoodle.StartUp | |
-- | |
import Prelude hiding ((.),id) | |
-- | | |
main :: IO () | |
main = do | |
hoodleStartMain defaultScriptConfig | |
{ message = Just welcomeMessage | |
, hook = Just newhook } | |
-- | | |
newhook :: Hook | |
newhook = | |
defaultHook { saveAsHook = Nothing | |
, afterSaveHook = Nothing | |
, afterOpenHook = Nothing | |
, afterUpdateClipboardHook = Nothing | |
, customContextMenuTitle = Just "take a memo" | |
, customContextMenuHook = Just custommenuhook | |
, fileNameSuggestionHook = Just fnamesuggest | |
, recentFolderHook = Nothing | |
, embedPredefinedImageHook = Just (return "/home/wavewave/Dropbox/memos/screenshot.png") | |
} | |
-- | | |
makesvg :: [Item] -> FilePath -> IO () | |
makesvg itms fp = do | |
mr <- renderitems itms | |
case mr of | |
Nothing -> return () | |
Just (BBox (ulx,uly) (lrx,lry),r) -> | |
withSVGSurface fp (lrx-ulx) (lry-uly) $ \s -> renderWith s r | |
-- | | |
makepng :: [Item] -> FilePath -> IO () | |
makepng itms fp = do | |
mr <- renderitems itms | |
case mr of | |
Nothing -> return () | |
Just (BBox (ulx,uly) (lrx,lry),r) -> | |
withImageSurface FormatARGB32 (floor (lrx-ulx)) (floor (lry-uly)) $ | |
\s -> do | |
renderWith s $ do | |
setSourceRGBA 1 1 1 1 | |
rectangle 0 0 (lrx-ulx) (lry-uly) | |
fill | |
r | |
surfaceWriteToPNG s fp | |
-- | | |
renderitems :: [Item] -> IO (Maybe (BBox, Render ())) | |
renderitems itms = do | |
ritms <- mapM cnstrctRItem itms | |
let ulbbox = unUnion . mconcat . fmap (Union . Middle . getBBox) $ ritms | |
case ulbbox of | |
Middle (bbox@(BBox (ulx,uly) (lrx,lry))) -> | |
let r = do translate (-ulx) (-uly) | |
mapM_ renderRItem ritms | |
in return (Just (bbox,r)) | |
_ -> return Nothing | |
-- | | |
custommenuhook :: [Item] -> IO () | |
custommenuhook is = do | |
ctime <- getCurrentTime | |
-- makesvg is ("/home/wavewave/Dropbox/memos" </> show ctime <.> "svg") | |
makepng is ("/home/wavewave/Dropbox/memos" </> show ctime <.> "png") | |
-- | | |
fnamesuggest :: IO FilePath | |
fnamesuggest = do | |
ctime <- getCurrentTime | |
return (show ctime <.> "hdl") | |
-- | | |
welcomeMessage :: String | |
welcomeMessage = | |
" ===================================================\n\ | |
\ = =\n\ | |
\ = welcome to hoodle =\n\ | |
\ = =\n\ | |
\ = Copyright 2011-2013 Ian-Woo Kim =\n\ | |
\ = =\n\ | |
\ = Date: 2013.01.16 =\n\ | |
\ = =\n\ | |
\ ===================================================\n" |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment