module Hoodle.Coroutine.File where
import Control.Applicative ((<$>),(<*>))
import Control.Concurrent
import Control.Lens (view,set,over,(%~))
import Control.Monad.State hiding (mapM,forM_)
import Control.Monad.Trans.Either
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.ByteString (readFile)
import Data.ByteString.Char8 as B (pack,unpack)
import qualified Data.ByteString.Lazy as L
import Data.Digest.Pure.MD5 (md5)
import Data.Foldable (forM_)
import qualified Data.List as List
import Data.Maybe
import qualified Data.IntMap as IM
import Data.Time.Clock
import Filesystem.Path.CurrentOS (decodeString, encodeString)
import Graphics.Rendering.Cairo
import Graphics.UI.Gtk hiding (get,set)
import System.Directory
import System.FilePath
import qualified System.FSNotify as FS
import System.IO (hClose, hFileSize, openFile, IOMode(..))
import System.Process
import Control.Monad.Trans.Crtn
import Control.Monad.Trans.Crtn.Queue
import Data.Hoodle.BBox
import Data.Hoodle.Generic
import Data.Hoodle.Simple
import Data.Hoodle.Select
import Graphics.Hoodle.Render.Generic
import Graphics.Hoodle.Render.Item
import Graphics.Hoodle.Render.Type
import Graphics.Hoodle.Render.Type.HitTest
import Text.Hoodle.Builder
import Hoodle.Accessor
import Hoodle.Coroutine.Dialog
import Hoodle.Coroutine.Draw
import Hoodle.Coroutine.Commit
import Hoodle.Coroutine.Minibuffer
import Hoodle.Coroutine.Mode
import Hoodle.Coroutine.Scroll
import Hoodle.Coroutine.TextInput
import Hoodle.ModelAction.File
import Hoodle.ModelAction.Layer
import Hoodle.ModelAction.Page
import Hoodle.ModelAction.Select
import Hoodle.ModelAction.Select.Transform
import Hoodle.ModelAction.Window
import qualified Hoodle.Script.Coroutine as S
import Hoodle.Script.Hook
import Hoodle.Type.Canvas
import Hoodle.Type.Coroutine
import Hoodle.Type.Event hiding (TypSVG)
import Hoodle.Type.HoodleState
import Hoodle.Type.PageArrangement
import Hoodle.Util
import Prelude hiding (readFile,concat,mapM)
askIfSave :: MainCoroutine () -> MainCoroutine ()
askIfSave action = do
xstate <- get
if not (view isSaved xstate)
then do
b <- okCancelMessageBox "Current canvas is not saved yet. Will you proceed without save?"
case b of
True -> action
False -> return ()
else action
askIfOverwrite :: FilePath -> MainCoroutine () -> MainCoroutine ()
askIfOverwrite fp action = do
b <- liftIO $ doesFileExist fp
if b
then do
r <- okCancelMessageBox ("Overwrite " ++ fp ++ "???")
if r then action else return ()
else action
fileNew :: MainCoroutine ()
fileNew = do
xstate <- get
xstate' <- liftIO $ getFileContent Nothing xstate
ncvsinfo <- liftIO $ setPage xstate' 0 (getCurrentCanvasId xstate')
xstate'' <- return $ over currentCanvasInfo (const ncvsinfo) xstate'
liftIO $ setTitleFromFileName xstate''
commit xstate''
invalidateAll
fileSave :: MainCoroutine ()
fileSave = do
xstate <- get
case view (hoodleFileControl.hoodleFileName) xstate of
Nothing -> fileSaveAs
Just filename -> do
if takeExtension filename == ".hdl"
then do
put =<< (liftIO (saveHoodle xstate))
(S.afterSaveHook filename . rHoodle2Hoodle . getHoodle) xstate
else fileExtensionInvalid (".hdl","save") >> fileSaveAs
sequence1_ :: (Monad m) => m () -> [m ()] -> m ()
sequence1_ _ [] = return ()
sequence1_ _ [a] = a
sequence1_ i (a:as) = a >> i >> sequence1_ i as
renderjob :: RHoodle -> FilePath -> IO ()
renderjob h ofp = do
let p = maybe (error "renderjob") id $ IM.lookup 0 (view gpages h)
let Dim width height = view gdimension p
let rf x = cairoRenderOption (RBkgDrawPDF,DrawFull) x >> return ()
withPDFSurface ofp width height $ \s -> renderWith s $
(sequence1_ showPage . map rf . IM.elems . view gpages ) h
fileExport :: MainCoroutine ()
fileExport = fileChooser FileChooserActionSave Nothing >>= maybe (return ()) action
where
action filename =
if takeExtension filename /= ".pdf"
then fileExtensionInvalid (".pdf","export") >> fileExport
else do
xstate <- get
let hdl = getHoodle xstate
liftIO (renderjob hdl filename)
fileStartSync :: MainCoroutine ()
fileStartSync = do
xst <- get
let mf = (,) <$> view (hoodleFileControl.hoodleFileName) xst <*> view (hoodleFileControl.lastSavedTime) xst
maybe (return ()) (\(filename,lasttime) -> action filename lasttime) mf
where
action filename _lasttime = do
let ioact = mkIOaction $ \evhandler ->do
forkIO $ do
FS.withManager $ \wm -> do
origfile <- canonicalizePath filename
let (filedir,_) = splitFileName origfile
print filedir
FS.watchDir wm (decodeString filedir) (const True) $ \ev -> do
let mchangedfile = case ev of
FS.Added fp _ -> Just (encodeString fp)
FS.Modified fp _ -> Just (encodeString fp)
FS.Removed _fp _ -> Nothing
print mchangedfile
case mchangedfile of
Nothing -> return ()
Just changedfile -> do
let changedfilename = takeFileName changedfile
changedfile' = (filedir </> changedfilename)
if changedfile' == origfile
then do
ctime <- getCurrentTime
evhandler (UsrEv (Sync ctime))
else return ()
let sec = 1000000
forever (threadDelay (100 * sec))
return (UsrEv ActionOrdered)
modify (tempQueue %~ enqueue ioact)
exportCurrentPageAsSVG :: MainCoroutine ()
exportCurrentPageAsSVG = fileChooser FileChooserActionSave Nothing >>= maybe (return ()) action
where
action filename =
if takeExtension filename /= ".svg"
then fileExtensionInvalid (".svg","export") >> exportCurrentPageAsSVG
else do
cpg <- getCurrentPageCurr
let Dim w h = view gdimension cpg
liftIO $ withSVGSurface filename w h $ \s -> renderWith s $
cairoRenderOption (InBBoxOption Nothing) (InBBox cpg) >> return ()
fileLoad :: FilePath -> MainCoroutine ()
fileLoad filename = do
xstate <- get
xstate' <- liftIO $ getFileContent (Just filename) xstate
ncvsinfo <- liftIO $ setPage xstate' 0 (getCurrentCanvasId xstate')
xstateNew <- return $ over currentCanvasInfo (const ncvsinfo) xstate'
put . set isSaved True $ xstateNew
let ui = view gtkUIManager xstate
liftIO $ toggleSave ui False
liftIO $ setTitleFromFileName xstateNew
clearUndoHistory
modeChange ToViewAppendMode
resetHoodleBuffers
invalidateAll
applyActionToAllCVS adjustScrollbarWithGeometryCvsId
resetHoodleBuffers :: MainCoroutine ()
resetHoodleBuffers = do
liftIO $ putStrLn "resetHoodleBuffers called"
xst <- get
nhdlst <- liftIO $ resetHoodleModeStateBuffers (view hoodleModeState xst)
let nxst = set hoodleModeState nhdlst xst
put nxst
fileOpen :: MainCoroutine ()
fileOpen = do
mfilename <- fileChooser FileChooserActionOpen Nothing
forM_ mfilename fileLoad
fileSaveAs :: MainCoroutine ()
fileSaveAs = do
xstate <- get
let hdl = (rHoodle2Hoodle . getHoodle) xstate
maybe (defSaveAsAction xstate hdl) (\f -> liftIO (f hdl))
(hookSaveAsAction xstate)
where
hookSaveAsAction xstate = do
hset <- view hookSet xstate
saveAsHook hset
defSaveAsAction xstate hdl = do
let msuggestedact = view hookSet xstate >>= fileNameSuggestionHook
(msuggested :: Maybe String) <- maybe (return Nothing) (liftM Just . liftIO) msuggestedact
mr <- fileChooser FileChooserActionSave msuggested
maybe (return ()) (action xstate hdl) mr
where action xst' hd filename =
if takeExtension filename /= ".hdl"
then fileExtensionInvalid (".hdl","save")
else do
askIfOverwrite filename $ do
let ntitle = B.pack . snd . splitFileName $ filename
(hdlmodst',hdl') = case view hoodleModeState xst' of
ViewAppendState hdlmap ->
if view gtitle hdlmap == "untitled"
then ( ViewAppendState . set gtitle ntitle
$ hdlmap
, (set title ntitle hd))
else (ViewAppendState hdlmap,hd)
SelectState thdl ->
if view gselTitle thdl == "untitled"
then ( SelectState $ set gselTitle ntitle thdl
, set title ntitle hd)
else (SelectState thdl,hd)
xstateNew = set (hoodleFileControl.hoodleFileName) (Just filename)
. set hoodleModeState hdlmodst' $ xst'
liftIO . L.writeFile filename . builder $ hdl'
put . set isSaved True $ xstateNew
let ui = view gtkUIManager xstateNew
liftIO $ toggleSave ui False
liftIO $ setTitleFromFileName xstateNew
S.afterSaveHook filename hdl'
fileReload :: MainCoroutine ()
fileReload = do
xstate <- get
case view (hoodleFileControl.hoodleFileName) xstate of
Nothing -> return ()
Just filename -> do
if not (view isSaved xstate)
then do
b <- okCancelMessageBox "Discard changes and reload the file?"
case b of
True -> fileLoad filename
False -> return ()
else fileLoad filename
fileExtensionInvalid :: (String,String) -> MainCoroutine ()
fileExtensionInvalid (ext,a) =
okMessageBox $ "only "
++ ext
++ " extension is supported for "
++ a
fileAnnotatePDF :: MainCoroutine ()
fileAnnotatePDF =
fileChooser FileChooserActionOpen Nothing >>= maybe (return ()) action
where
warning = do
okMessageBox "cannot load the pdf file. Check your hoodle compiled with poppler library"
invalidateAll
action filename = do
xstate <- get
let doesembed = view (settings.doesEmbedPDF) xstate
mhdl <- liftIO $ makeNewHoodleWithPDF doesembed filename
flip (maybe warning) mhdl $ \hdl -> do
xstateNew <- return . set (hoodleFileControl.hoodleFileName) Nothing
=<< (liftIO $ constructNewHoodleStateFromHoodle hdl xstate)
commit xstateNew
liftIO $ setTitleFromFileName xstateNew
invalidateAll
checkEmbedImageSize :: FilePath -> MainCoroutine (Maybe FilePath)
checkEmbedImageSize filename = do
xst <- get
runMaybeT $ do
sizelimit <- (MaybeT . return) (warningEmbedImageSize =<< view hookSet xst)
siz <- liftIO $ do
h <- openFile filename ReadMode
s <- hFileSize h
hClose h
return s
guard (siz > sizelimit)
let suggestscale :: Double = sqrt (fromIntegral sizelimit / fromIntegral siz)
b <- lift . okCancelMessageBox $ "The size of " ++ filename ++ "=" ++ show siz ++ "\nis bigger than limit=" ++ show sizelimit ++ ".\nWill you reduce size?"
guard b
let ext = let x' = takeExtension filename
in if (not.null) x' then tail x' else ""
tmpfile <- liftIO $ mkTmpFile ext
cmd <- (MaybeT . return) (shrinkCmd4EmbedImage =<< view hookSet xst)
liftIO $ cmd suggestscale filename tmpfile
return tmpfile
fileLoadPNGorJPG :: MainCoroutine ()
fileLoadPNGorJPG = do
fileChooser FileChooserActionOpen Nothing >>= maybe (return ()) embedImage
embedImage :: FilePath -> MainCoroutine ()
embedImage filename = do
xst <- get
nitm <-
if view (settings.doesEmbedImage) xst
then do
mf <- checkEmbedImageSize filename
case mf of
Nothing -> liftIO (cnstrctRItem =<< makeNewItemImage True filename)
Just f -> liftIO (cnstrctRItem =<< makeNewItemImage True f)
else
liftIO (cnstrctRItem =<< makeNewItemImage False filename)
insertItemAt Nothing nitm
insertItemAt :: Maybe (PageNum,PageCoordinate)
-> RItem
-> MainCoroutine ()
insertItemAt mpcoord ritm = do
xst <- get
geometry <- liftIO (getGeometry4CurrCvs xst)
let hdl = getHoodle xst
(pgnum,mpos) = case mpcoord of
Just (PageNum n,pos) -> (n,Just pos)
Nothing -> (view (currentCanvasInfo . unboxLens currentPageNum) xst,Nothing)
(ulx,uly) = (bbox_upperleft.getBBox) ritm
nitms =
case mpos of
Nothing -> adjustItemPosition4Paste geometry (PageNum pgnum) [ritm]
Just (PageCoord (nx,ny)) ->
map (changeItemBy (\(x,y)->(x+nxulx,y+nyuly))) [ritm]
let pg = getPageFromGHoodleMap pgnum hdl
lyr = getCurrentLayer pg
oitms = view gitems lyr
ntpg = makePageSelectMode pg (oitms :- (Hitted nitms) :- Empty)
modeChange ToSelectMode
nxst <- get
thdl <- case view hoodleModeState nxst of
SelectState thdl' -> return thdl'
_ -> (lift . EitherT . return . Left . Other) "insertItemAt"
nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum
put ( ( set hoodleModeState (SelectState nthdl)
. set isOneTimeSelectMode YesAfterSelect) nxst)
invalidateAll
fileLoadSVG :: MainCoroutine ()
fileLoadSVG = do
fileChooser FileChooserActionOpen Nothing >>= maybe (return ()) action
where
action filename = do
xstate <- get
liftIO $ putStrLn filename
bstr <- liftIO $ readFile filename
let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) xstate
hdl = getHoodle xstate
currpage = getPageFromGHoodleMap pgnum hdl
currlayer = getCurrentLayer currpage
newitem <- (liftIO . cnstrctRItem . ItemSVG)
(SVG Nothing Nothing bstr (100,100) (Dim 300 300))
let otheritems = view gitems currlayer
let ntpg = makePageSelectMode currpage (otheritems :- (Hitted [newitem]) :- Empty)
modeChange ToSelectMode
nxstate <- get
thdl <- case view hoodleModeState nxstate of
SelectState thdl' -> return thdl'
_ -> (lift . EitherT . return . Left . Other) "fileLoadSVG"
nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum
put ( ( set hoodleModeState (SelectState nthdl)
. set isOneTimeSelectMode YesAfterSelect) nxstate)
invalidateAll
askQuitProgram :: MainCoroutine ()
askQuitProgram = do
b <- okCancelMessageBox "Current canvas is not saved yet. Will you close hoodle?"
case b of
True -> liftIO mainQuit
False -> return ()
embedPredefinedImage :: MainCoroutine ()
embedPredefinedImage = do
mpredefined <- S.embedPredefinedImageHook
case mpredefined of
Nothing -> return ()
Just filename -> embedImage filename
embedPredefinedImage2 :: MainCoroutine ()
embedPredefinedImage2 = do
mpredefined <- S.embedPredefinedImage2Hook
case mpredefined of
Nothing -> return ()
Just filename -> embedImage filename
embedPredefinedImage3 :: MainCoroutine ()
embedPredefinedImage3 = do
mpredefined <- S.embedPredefinedImage3Hook
case mpredefined of
Nothing -> return ()
Just filename -> embedImage filename
embedAllPDFBackground :: MainCoroutine ()
embedAllPDFBackground = do
xst <- get
let hdl = getHoodle xst
nhdl <- liftIO . embedPDFInHoodle $ hdl
modeChange ToViewAppendMode
commit (set hoodleModeState (ViewAppendState nhdl) xst)
invalidateAll
mkRevisionHdlFile :: Hoodle -> IO (String,String)
mkRevisionHdlFile hdl = do
hdir <- getHomeDirectory
tempfile <- mkTmpFile "hdl"
let hdlbstr = builder hdl
L.writeFile tempfile hdlbstr
ctime <- getCurrentTime
let idstr = B.unpack (view hoodleID hdl)
md5str = show (md5 hdlbstr)
name = "UUID_"++idstr++"_MD5Digest_"++md5str++"_ModTime_"++ show ctime
nfilename = name <.> "hdl"
vcsdir = hdir </> ".hoodle.d" </> "vcs"
b <- doesDirectoryExist vcsdir
unless b $ createDirectory vcsdir
renameFile tempfile (vcsdir </> nfilename)
return (md5str,name)
mkRevisionPdfFile :: RHoodle -> String -> IO ()
mkRevisionPdfFile hdl fname = do
hdir <- getHomeDirectory
tempfile <- mkTmpFile "pdf"
renderjob hdl tempfile
let nfilename = fname <.> "pdf"
vcsdir = hdir </> ".hoodle.d" </> "vcs"
b <- doesDirectoryExist vcsdir
unless b $ createDirectory vcsdir
renameFile tempfile (vcsdir </> nfilename)
fileVersionSave :: MainCoroutine ()
fileVersionSave = do
rhdl <- getHoodle <$> get
let hdl = rHoodle2Hoodle rhdl
rmini <- minibufDialog "Commit Message:"
case rmini of
Right [] -> return ()
Right strks' -> do
doIOaction $ \_evhandler -> do
(md5str,fname) <- mkRevisionHdlFile hdl
mkRevisionPdfFile rhdl fname
return (UsrEv (GotRevisionInk md5str strks'))
r <- waitSomeEvent (\case GotRevisionInk _ _ -> True ; _ -> False )
let GotRevisionInk md5str strks = r
nrev = RevisionInk (B.pack md5str) strks
modify (\xst -> let hdlmodst = view hoodleModeState xst
in case hdlmodst of
ViewAppendState rhdl' ->
let nrhdl = over grevisions (<> [nrev]) rhdl'
in set hoodleModeState (ViewAppendState nrhdl) xst
SelectState thdl ->
let nthdl = over gselRevisions (<> [nrev]) thdl
in set hoodleModeState (SelectState nthdl) xst)
commit_
Left () -> do
txtstr <- maybe "" id <$> textInputDialog
doIOaction $ \_evhandler -> do
(md5str,fname) <- mkRevisionHdlFile hdl
mkRevisionPdfFile rhdl fname
return (UsrEv (GotRevision md5str txtstr))
r <- waitSomeEvent (\case GotRevision _ _ -> True ; _ -> False )
let GotRevision md5str txtstr' = r
nrev = Revision (B.pack md5str) (B.pack txtstr')
modify (\xst -> let hdlmodst = view hoodleModeState xst
in case hdlmodst of
ViewAppendState rhdl' ->
let nrhdl = over grevisions (<> [nrev]) rhdl'
in set hoodleModeState (ViewAppendState nrhdl) xst
SelectState thdl ->
let nthdl = over gselRevisions (<> [nrev]) thdl
in set hoodleModeState (SelectState nthdl) xst)
commit_
showRevisionDialog :: Hoodle -> [Revision] -> MainCoroutine ()
showRevisionDialog hdl revs =
modify (tempQueue %~ enqueue action)
>> waitSomeEvent (\case GotOk -> True ; _ -> False)
>> return ()
where
action = mkIOaction $ \_evhandler -> do
dialog <- dialogNew
vbox <- dialogGetUpper dialog
mapM_ (addOneRevisionBox vbox hdl) revs
_btnOk <- dialogAddButton dialog "Ok" ResponseOk
widgetShowAll dialog
_res <- dialogRun dialog
widgetDestroy dialog
return (UsrEv GotOk)
mkPangoText :: String -> Render ()
mkPangoText str = do
let pangordr = do
ctxt <- cairoCreateContext Nothing
layout <- layoutEmpty ctxt
fdesc <- fontDescriptionNew
fontDescriptionSetFamily fdesc "Sans Mono"
fontDescriptionSetSize fdesc 8.0
layoutSetFontDescription layout (Just fdesc)
layoutSetWidth layout (Just 250)
layoutSetWrap layout WrapAnywhere
layoutSetText layout str
return layout
rdr layout = do setSourceRGBA 0 0 0 1
updateLayout layout
showLayout layout
layout <- liftIO $ pangordr
rdr layout
addOneRevisionBox :: VBox -> Hoodle -> Revision -> IO ()
addOneRevisionBox vbox hdl rev = do
cvs <- drawingAreaNew
cvs `on` sizeRequest $ return (Requisition 250 25)
cvs `on` exposeEvent $ tryEvent $ do
drawwdw <- liftIO $ widgetGetDrawWindow cvs
liftIO . renderWithDrawable drawwdw $ do
case rev of
RevisionInk _ strks -> scale 0.5 0.5 >> mapM_ cairoRender strks
Revision _ txt -> mkPangoText (B.unpack txt)
hdir <- getHomeDirectory
let vcsdir = hdir </> ".hoodle.d" </> "vcs"
btn <- buttonNewWithLabel "view"
btn `on` buttonPressEvent $ tryEvent $ do
files <- liftIO $ getDirectoryContents vcsdir
let fstrinit = "UUID_" ++ B.unpack (view hoodleID hdl)
++ "_MD5Digest_" ++ B.unpack (view revmd5 rev)
matched = filter ((== "fdp") . take 3 . reverse)
. filter (\f -> fstrinit `List.isPrefixOf` f) $ files
case matched of
x : _ ->
liftIO (createProcess (proc "evince" [vcsdir </> x]))
>> return ()
_ -> return ()
hbox <- hBoxNew False 0
boxPackStart hbox cvs PackNatural 0
boxPackStart hbox btn PackGrow 0
boxPackStart vbox hbox PackNatural 0
fileShowRevisions :: MainCoroutine ()
fileShowRevisions = do
rhdl <- liftM getHoodle get
let hdl = rHoodle2Hoodle rhdl
let revs = view grevisions rhdl
showRevisionDialog hdl revs
fileShowUUID :: MainCoroutine ()
fileShowUUID = do
hdl <- liftM getHoodle get
let uuidstr = view ghoodleID hdl
okMessageBox (B.unpack uuidstr)