hoodle start.hs script example

start.hs

{-# 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"