fenfire-0.1: _darcs/pristine/Fenfire.fhs
{-# OPTIONS_GHC -fallow-overlapping-instances -fimplicit-params #-}
module Fenfire where
-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup
-- This file is part of Fenfire.
--
-- Fenfire is free software; you can redistribute it and/or modify it under
-- the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or
-- (at your option) any later version.
--
-- Fenfire is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
-- Public License for more details.
--
-- You should have received a copy of the GNU General
-- Public License along with Fenfire; if not, write to the Free
-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
-- MA 02111-1307 USA
import qualified Cache
import Cairo hiding (rotate)
import Vobs
import Utils
import RDF
import Paths_fenfire (getDataFileName)
import qualified Raptor (filenameToTriples, triplesToFilename, Identifier(..))
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Tree as Tree
import qualified Data.List
import Data.Set (Set)
import Data.IORef
import Data.Maybe (fromJust, isJust, isNothing, catMaybes)
import Data.Monoid(Monoid(mconcat), Dual(Dual), getDual)
import Control.Applicative
import Control.Monad (when, guard, msum)
import Control.Monad.Reader (ReaderT, runReaderT, local, ask, asks)
import Control.Monad.State (StateT, get, gets, modify, put, execStateT)
import Control.Monad.Trans (lift, liftIO)
import Control.Monad.Writer (Writer, execWriter, tell)
import Graphics.UI.Gtk hiding (Color, get, disconnect, fill)
import qualified Control.Exception
import System.Directory (canonicalizePath)
import System.Environment (getArgs, getProgName)
import System.Mem.StableName
import System.Random (randomRIO)
data ViewSettings = ViewSettings { hiddenProps :: [Node] }
data FenState = FenState { fsRotation :: Rotation, fsMark :: Mark,
fsFilePath :: FilePath, fsGraphModified :: Bool,
fsHasFocus :: Bool }
data Rotation = Rotation Graph Node Int deriving (Eq, Show)
getRotation :: (?vs :: ViewSettings) => Graph -> Node -> Node -> Dir -> Node ->
Maybe Rotation
getRotation graph node prop dir node' = do
i <- Data.List.elemIndex (prop, node') (conns graph node dir)
return (Rotation graph node
(i - (length (conns graph node dir) `div` 2)))
connsCache :: Cache.Cache (StableName Graph, (Node, Dir)) [(Node, Node)]
connsCache = Cache.newCache 10000
dc_date = URI "dc:date"
conns :: (?vs :: ViewSettings) => Graph -> Node -> Dir -> [(Node, Node)]
conns g node dir = cached where
cached = Cache.cached (Cache.byAddress g, (node,dir)) connsCache result
result = Data.List.sortBy cmp' list
list = [(p,n) | (p,s) <- Map.toList $ getConns g node dir,
not (p `elem` hiddenProps ?vs), n <- Set.toList s]
cmp n1 n2 | p n1 && p n2 = compare (f n1) (f n2) where
p n = hasConn g n dc_date Pos; f n = getOne g n dc_date Pos
cmp n1 n2 = compare (getText g n1) (getText g n2)
cmp' (p1,n1) (p2,n2) = catOrds (cmp p1 p2) (cmp n1 n2)
catOrds EQ o = o; catOrds o _ = o
getConn :: (?vs :: ViewSettings) => Rotation -> Dir -> Maybe (Node, Rotation)
getConn (Rotation graph node r) dir = do
let c = conns graph node dir; i = (length c `div` 2) + r
guard $ i >= 0 && i < length c; let (p,n) = c !! i
rot <- getRotation graph n p (rev dir) node
return (p,rot)
rotate :: (?vs :: ViewSettings) => Rotation -> Int -> Maybe Rotation
rotate (Rotation g n r) dir = let rot = Rotation g n (r+dir) in do
guard $ any isJust [getConn rot d | d <- [Pos, Neg]]; return rot
move :: (?vs :: ViewSettings) => Rotation -> Dir -> Maybe Rotation
move rot dir = fmap snd (getConn rot dir)
getText :: Graph -> Node -> Maybe String
getText g n = fmap f $ getOne g n rdfs_label Pos where
f (PlainLiteral s) = s; f _ = error "getText argh"
setText :: Graph -> Node -> String -> Graph
setText g n t = update (n, rdfs_label, PlainLiteral t) g
nodeView :: Graph -> Node -> Vob Node
nodeView g n = rectBox $ pad 5 $ useFgColor $ multiline False 20 s
where s = maybe (show n) id (getText g n)
propView :: Graph -> Node -> Vob Node
propView g n = (useFadeColor $ fill extents)
& (pad 5 $ useFgColor $ label $ maybe (show n) id (getText g n))
vanishingView :: (?vs :: ViewSettings) => Int -> Int -> Color -> Color ->
Color -> Color -> FenState -> Vob Node
vanishingView depth maxnodes bgColor blurBgColor focusColor blurColor
(FenState {fsRotation=startRotation, fsMark=mark,
fsHasFocus=focus}) =
runVanishing depth maxnodes view where
-- place the center of the view and all subtrees in both directions
view = do placeNode (if focus then Just (bgColor, focusColor)
else Just (blurBgColor, blurColor))
startRotation
let Rotation _ n _ = startRotation in visitNode n
forM_ [Pos, Neg] $ \dir -> do
placeConns startRotation dir True
-- place all subtrees in xdir
placeConns rotation xdir placeFirst = withDepthIncreased 1 $ do
when placeFirst $ placeConn rotation xdir
forM_ [-1, 1] $ \ydir -> do
placeConns' rotation xdir ydir
-- place rest of the subtrees in (xdir, ydir)
placeConns' rotation xdir ydir = withDepthIncreased 1 $
maybeDo (rotate rotation ydir) $ \rotation' -> do
withAngleChanged (fromIntegral ydir * mul xdir pi / 14) $ do
placeConn rotation' xdir
placeConns' rotation' xdir ydir
-- place one subtree
placeConn rotation@(Rotation graph n1 _) dir = withDepthIncreased 1 $
maybeDo (getConn rotation dir) $ \(prop, rotation') -> do
let Rotation _ n2 _ = rotation'
scale' <- getScale
withCenterMoved dir (280 * (scale'**3)) $ do
ifUnvisited n2 $ placeNode Nothing rotation'
let (nl,nr) = if dir==Pos then (n1,n2) else (n2,n1)
addVob $ between (center @@ nl) (center @@ nr) $ ownSize $
centerVob $ scale #scale' $ propView graph prop
addVob $ useFgColor $ stroke $
line (center @@ nl) (center @@ nr)
ifUnvisited n2 $ visitNode n2 >> do
placeConns rotation' dir True
withDepthIncreased 3 $
placeConns rotation' (rev dir) False
-- place one node view
placeNode cols (Rotation graph node _) = do
scale' <- getScale
let f vob = case bg of Nothing -> vob
Just c -> setBgColor c vob
markColor = if node `Set.member` mark then Just (Color 1 0 0 1)
else Nothing
bg = combine (fmap snd cols) markColor
combine Nothing c = c
combine c Nothing = c
combine (Just c1) (Just c2) = Just $ interpolate 0.5 c1 c2
g vob = case cols of Nothing -> vob
Just (c,_) -> frame c & vob
where (w,h) = defaultSize vob
frame c = withColor #c $ fill $
moveTo (point #(0-10) #(0-10)) &
lineTo (point #(w+10) #(0-10)) &
lineTo (point #(w+10) #(h+10)) &
lineTo (point #(0-10) #(h+10)) &
lineTo (point #(0-10) #(0-10))
placeVob $ ownSize $ scale #scale' $ keyVob node $ g $ f $
nodeView graph node
getScale :: VV Double
getScale = do d <- asks vvDepth; return (0.97 ** fromIntegral d)
data VVState = VVState { vvDepth :: Int, vvMaxDepth :: Int, vvMaxNodes :: Int,
vvX :: Double, vvY :: Double, vvAngle :: Double }
type VV a = ReaderT VVState (BreadthT (StateT (Set Node)
(Writer (Dual (Vob Node))))) a
runVanishing :: Int -> Int -> VV () -> Vob Node
runVanishing maxdepth maxnodes vv = comb (0,0) $ \cx ->
let (w,h) = rcSize cx
in getDual $ execWriter $ flip execStateT Set.empty $ execBreadthT $
runReaderT vv $ VVState 0 maxdepth maxnodes (w/2) (h/2) 0
-- |Execute the passed action with the recursion depth increased by
-- the given amount of steps, if it is still smaller than the maximum
-- recursion depth.
--
withDepthIncreased :: Int -> VV () -> VV ()
withDepthIncreased n m = do
state <- ask; let state' = state { vvDepth = vvDepth state + n }
if vvDepth state' >= vvMaxDepth state' then return () else
lift $ scheduleBreadthT $ flip runReaderT state' $ do
visited <- get
when (Set.size visited <= (4 * vvMaxNodes state') `div` 3) m
visitNode :: Node -> VV ()
visitNode n = modify (Set.insert n)
ifUnvisited :: Node -> VV () -> VV ()
ifUnvisited n m = do visited <- get
when (not $ n `Set.member` visited) m
addVob :: Vob Node -> VV ()
addVob vob = do d <- asks vvDepth; md <- asks vvMaxDepth
mn <- asks vvMaxNodes; visited <- get
let x = (fromIntegral (md - d) / fromIntegral (md+2))
vob' = if Set.size visited >= mn then invisibleVob vob
else fade x vob
tell (Dual vob')
placeVob :: Vob Node -> VV ()
placeVob vob = do
state <- ask
addVob $ translate #(vvX state) #(vvY state) $ centerVob vob
withCenterMoved :: Dir -> Double -> VV () -> VV ()
withCenterMoved dir distance = local f where
distance' = mul dir distance
f s = s { vvX = vvX s + distance' * cos (vvAngle s),
vvY = vvY s + distance' * sin (vvAngle s) }
withAngleChanged :: Double -> VV () -> VV ()
withAngleChanged delta = local $ \s -> s { vvAngle = vvAngle s + delta }
tryMove :: (?vs :: ViewSettings) => Rotation -> Dir -> Maybe Rotation
tryMove rot@(Rotation g n r) dir = maybe rot' Just (move rot dir) where
rot' | r == nearest = Nothing
| otherwise = Just $ Rotation g n nearest
nearest | r > 0 = len-1 - len `div` 2
| otherwise = 0 - len `div` 2
len = (length $ conns g n dir)
type URIMaker = (String, IORef Integer)
newURIMaker :: IO URIMaker
newURIMaker = do rand <- sequence [randomRIO (0,63) | _ <- [1..27::Int]]
let chars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "+-"
ref <- newIORef 1
return ("urn:urn-5:" ++ map (chars !!) rand, ref)
newURI :: (?uriMaker :: URIMaker) => IO Node
newURI = do let (base, ref) = ?uriMaker
i <- readIORef ref; writeIORef ref (i+1)
return $ URI (base ++ ":" ++ show i)
newNode :: (?vs :: ViewSettings, ?uriMaker :: URIMaker) =>
Rotation -> Dir -> IO Rotation
newNode (Rotation graph node _) dir = do
node' <- newURI
let graph' = insert (triple dir (node, rdfs_seeAlso, node'))
$ insert (node', rdfs_label, PlainLiteral "") graph
return $ fromJust $ getRotation graph' node' rdfs_seeAlso (rev dir) node
connect :: (?vs :: ViewSettings) => Rotation -> Dir -> Mark -> Rotation
connect r _ mark | Set.null mark = r
connect (Rotation graph node _) dir mark =
let nodes = Set.toList mark
graph' = foldr (\n -> insert $ triple dir (node, rdfs_seeAlso, n))
graph nodes
in fromJust $ getRotation graph' node rdfs_seeAlso dir (head nodes)
disconnect :: (?vs :: ViewSettings) => Rotation -> Dir -> Maybe Rotation
disconnect (Rotation graph node rot) dir =
let
c = conns graph node dir
index = (length c `div` 2) + rot
(p,n) = c !! index
graph' = delete (triple dir (node, p, n)) graph
index' = ((length c - 1) `div` 2) + rot
rot' = case index' of x | x == -1 -> rot+1
| x == length c - 1 && x /= 0 -> rot-1
| otherwise -> rot
in
if index >= 0 && index < length c
then Just $ Rotation graph' node rot'
else Nothing
type Mark = Set Node
toggleMark :: Node -> Mark -> Mark
toggleMark n mark | n `Set.member` mark = Set.delete n mark
| otherwise = Set.insert n mark
newGraph :: (?uriMaker :: URIMaker) => IO Rotation
newGraph = do
home0 <- newURI
let graph0 = listToGraph [(home0, rdfs_label, PlainLiteral "")]
rot0 = (Rotation graph0 home0 0)
return rot0
findStartRotation :: (?vs :: ViewSettings) => Graph -> Rotation
findStartRotation g = head $ catMaybes $ startNode:topic:triples where
self = URI "ex:graph" -- ought to be what the empty URI <> is expanded to
startNode = getRot =<< getTriple self ffv_startNode
topic = getRot =<< getTriple self foaf_primaryTopic
triples = map getRot $ graphToList g
getTriple s p = fmap (\o -> (s,p,o)) $ getOne g s p Pos
getRot (s,p,o) = getRotation g o p Neg s
ffv_startNode = URI "http://fenfire.org/rdf-v/2003/05/ff#startNode"
foaf_primaryTopic = URI "http://xmlns.com/foaf/0.1/primaryTopic"
loadGraph :: FilePath -> IO Graph
loadGraph fileName = do
--file <- readFile fileName
--graph <- fromNTriples file >>= return . reverse-}
let convert (s,p,o) = (f s, f p, f o)
f (Raptor.Uri s) = URI s
f (Raptor.Literal s) = PlainLiteral s
f (Raptor.Blank s) = URI $ "blank:" ++ s
triples <- Raptor.filenameToTriples fileName >>= return . map convert
return $ listToGraph triples
saveGraph :: Graph -> FilePath -> IO ()
saveGraph graph fileName = do
--writeFile fileName $ toNTriples $ reverse graph
let convert (s,p,o) = (f s, f p, f o)
f (URI s) = Raptor.Uri s
f (PlainLiteral s) = Raptor.Literal s
triples = graphToList graph
Raptor.triplesToFilename (map convert triples) fileName
putStrLn $ "Saved: " ++ fileName
openFile :: (?vs :: ViewSettings) => Rotation -> FilePath ->
IO (Rotation,FilePath)
openFile rot0 fileName0 = do
dialog <- fileChooserDialogNew Nothing Nothing FileChooserActionOpen
[(stockCancel, ResponseCancel),
(stockOpen, ResponseAccept)]
when (fileName0 /= "") $ do fileChooserSetFilename dialog fileName0
return ()
response <- dialogRun dialog
widgetHide dialog
case response of
ResponseAccept -> do Just fileName <- fileChooserGetFilename dialog
graph <- loadGraph fileName
return (findStartRotation graph, fileName)
_ -> return (rot0, fileName0)
saveFile :: Rotation -> FilePath -> Bool -> IO (FilePath,Bool)
saveFile (Rotation graph _ _) fileName0 confirmSame = do
dialog <- fileChooserDialogNew Nothing Nothing FileChooserActionSave
[(stockCancel, ResponseCancel),
(stockSave, ResponseAccept)]
fileChooserSetDoOverwriteConfirmation dialog True
dialogSetDefaultResponse dialog ResponseAccept
when (fileName0 /= "") $ do fileChooserSetFilename dialog fileName0
return ()
onConfirmOverwrite dialog $ do
Just fileName <- fileChooserGetFilename dialog
if fileName == fileName0 && not confirmSame
then return FileChooserConfirmationAcceptFilename
else return FileChooserConfirmationConfirm
response <- dialogRun dialog
widgetHide dialog
case response of
ResponseAccept -> do Just fileName <- fileChooserGetFilename dialog
let fileName' = checkSuffix fileName
saveGraph graph fileName'
return (fileName', True)
_ -> return (fileName0, False)
checkSuffix :: FilePath -> FilePath
checkSuffix s | Data.List.isSuffixOf ".nt" s = s
| otherwise = s ++ ".nt"
confirmSave :: (?vs :: ViewSettings, ?pw :: Window, ?uriMaker :: URIMaker) =>
Bool -> HandlerAction FenState ->
HandlerAction FenState
confirmSave False action = action
confirmSave True action = do
response <- liftIO $ do
dialog <- makeConfirmUnsavedDialog
response' <- dialogRun dialog
widgetHide dialog
return response'
case response of ResponseClose -> action
ResponseAccept -> do
handleAction "save"
saved <- get >>= return . not . fsGraphModified
when (saved) action
_ -> return ()
confirmRevert :: (?vs :: ViewSettings, ?pw :: Window) =>
Bool -> HandlerAction FenState ->
HandlerAction FenState
confirmRevert False action = action
confirmRevert True action = do
response <- liftIO $ do
dialog <- makeConfirmRevertDialog
response' <- dialogRun dialog
widgetHide dialog
return response'
case response of ResponseClose -> action
_ -> return ()
newState :: Rotation -> FilePath -> Bool -> FenState
newState rot fp focus = FenState rot Set.empty fp False focus
handleEvent :: (?vs :: ViewSettings, ?pw :: Window,
?uriMaker :: URIMaker) => Handler Event FenState
handleEvent (Key { eventModifier=_mods, eventKeyName=key }) = do
state <- get; let rot = fsRotation state; fileName = fsFilePath state
case key of
x | x == "Up" || x == "i" -> handleAction "up"
x | x == "Down" || x == "comma" -> handleAction "down"
x | x == "Left" || x == "j" -> handleAction "left"
x | x == "Right" || x == "l" -> handleAction "right"
"O" -> handleAction "open"
"S" -> do (fp',saved) <- liftIO $ saveFile rot fileName False
let modified' = fsGraphModified state && not saved
put $ state { fsFilePath = fp', fsGraphModified = modified' }
_ -> unhandledEvent
handleEvent _ = unhandledEvent
handleAction :: (?vs :: ViewSettings, ?pw :: Window,
?uriMaker :: URIMaker) => Handler String FenState
handleAction action = do
FenState { fsRotation = rot@(Rotation graph node _), fsMark = mark,
fsFilePath = filepath, fsGraphModified = modified,
fsHasFocus=focus
} <- get
let m f x = maybeDo (f rot x) putRotation
b f x = maybeDo (f rot x) $ \rot' -> do
putRotation rot'
modify $ \s -> s { fsGraphModified = modified }
n f x = liftIO (f rot x) >>= putRotation
o f x = putState (f rot x mark) Set.empty
case action of
"up" -> b rotate (-1) ; "down" -> b rotate 1
"left" -> b tryMove Neg ; "right" -> b tryMove Pos
"nodel" -> n newNode Neg ; "noder" -> n newNode Pos
"connl" -> o connect Neg ; "connr" -> o connect Pos
"breakl"-> m disconnect Neg ; "breakr"-> m disconnect Pos
"rmlit" -> putState (delLit rot) mark
"mark" -> putMark $ toggleMark node mark
"new" -> confirmSave modified $ do
rot' <- liftIO newGraph
put $ newState rot' "" focus
"open" -> confirmSave modified $ do
(rot',fp') <- liftIO $ openFile rot filepath
put $ newState rot' fp' focus
"revert" | filepath /= "" -> confirmRevert modified $ do
g' <- liftIO $ loadGraph filepath
put $ newState (findStartRotation g') filepath focus
"save" | filepath /= "" -> do
liftIO $ saveGraph graph filepath
modify $ \s -> s { fsGraphModified = False }
| otherwise -> handleAction "saveas"
"saveas"-> do
(fp',saved) <- liftIO $ saveFile rot filepath True
let modified' = modified && not saved
modify $ \s -> s { fsFilePath = fp', fsGraphModified = modified' }
"quit" -> do confirmSave modified $ liftIO mainQuit
"about" -> liftIO $ makeAboutDialog >>= widgetShow
_ -> unhandledEvent
where putRotation rot = do modify $ \state -> state { fsRotation=rot,
fsGraphModified=True }
setInterp True
putMark mk = do modify $ \state -> state { fsMark=mk }
putState rot mk = do putMark mk; putRotation rot
delLit (Rotation g n r) = Rotation (deleteAll n rdfs_label g) n r
makeActions actionGroup accelGroup = do
let actionentries =
[ ( "new" , stockNew )
, ( "open" , stockOpen )
, ( "save" , stockSave )
, ( "saveas" , stockSaveAs )
, ( "revert" , stockRevertToSaved )
, ( "quit" , stockQuit )
, ( "about" , stockAbout )
]
flip mapM actionentries $ \(name,stock) -> do
item <- stockLookupItem stock -- XXX Gtk2Hs actionNew needs the label
action <- actionNew name (siLabel $ fromJust item) Nothing (Just stock)
actionGroupAddActionWithAccel actionGroup action Nothing
actionSetAccelGroup action accelGroup
updateActionSensitivity actionGroup modified readable = do
Just save <- actionGroupGetAction actionGroup "save"
actionSetSensitive save modified
Just revert <- actionGroupGetAction actionGroup "revert"
actionSetSensitive revert (modified && readable)
makeBindings actionGroup bindings = do
let bindingentries =
[ ("noder" , Just "_New node to right" ,
stockMediaForward , Just "n" )
, ("nodel" , Just "N_ew node to left" ,
stockMediaRewind , Just "<Shift>N" )
, ("breakr" , Just "_Break connection to right" ,
stockGotoLast , Just "b" )
, ("breakl" , Just "B_reak connection to left" ,
stockGotoFirst , Just "<Shift>B" )
, ("mark" , Just "Toggle _mark" ,
stockOk , Just "m" )
, ("connr" , Just "_Connect marked to right" ,
stockGoForward , Just "c" )
, ("connl" , Just "C_onnect marked to left" ,
stockGoBack , Just "<Shift>C" )
, ("rmlit" , Just "Remove _literal text" ,
stockStrikethrough , Just "<Alt>BackSpace" )
]
flip mapM bindingentries $ \(name,label',stock,accel) -> do
item <- stockLookupItem stock -- XXX Gtk2Hs actionNew needs the label
let label'' = maybe (siLabel $ fromJust item) id label'
action <- actionNew name label'' Nothing (Just stock)
actionGroupAddActionWithAccel actionGroup action accel
actionSetAccelGroup action bindings
makeMenus actionGroup root = mapM_ (createMenu root) menuentries
where
leaf x = Tree.Node x []
menuentries = [ Tree.Node "_File" (map leaf ["new","open","",
"save","saveas","revert",
"",
"quit"])
, Tree.Node "_Edit" (map leaf ["noder","nodel","",
"breakr","breakl","",
"mark","connr","connl","",
"rmlit"])
, Tree.Node "_Help" (map leaf ["about"])
]
createMenu :: MenuShellClass menu => menu -> Tree.Tree String -> IO ()
createMenu parent (Tree.Node name children) =
if children /= [] then do
item <- menuItemNewWithMnemonic name
menu <- menuNew
mapM_ (createMenu menu) children
menuItemSetSubmenu item menu
menuShellAppend parent item
else
if name == "" then do
item <- separatorMenuItemNew
menuShellAppend parent item
else do
Just action <- actionGroupGetAction actionGroup name
item <- actionCreateMenuItem action
menuShellAppend parent (castToMenuItem item)
makeToolbarItems actionGroup toolbar = do
forM_ ["new", "open", "", "save"] $ \name ->
if name == "" then do
item <- separatorToolItemNew
toolbarInsert toolbar item (-1)
else do
Just action <- actionGroupGetAction actionGroup name
item <- actionCreateToolItem action
toolbarInsert toolbar (castToToolItem item) (-1)
main :: IO ()
main = do
uriMaker <- newURIMaker
let ?vs = ViewSettings { hiddenProps=[rdfs_label] }
?uriMaker = uriMaker in do
-- initial state:
args <- initGUI
let view = vanishingView 20 30
(Color 0.7 0.7 0.8 0.7) (Color 0.7 0.7 0.7 0.7)
(Color 0.93 0.93 1 1) (Color 0.93 0.93 0.93 1)
stateRef <- case args of
[] -> do
rot <- newGraph
newIORef $ newState rot "" False
xs -> do
fileName:fileNames <- mapM canonicalizePath xs
g' <- loadGraph fileName
gs <- mapM loadGraph fileNames
let rot = findStartRotation (foldl mergeGraphs g' gs)
newIORef $ newState rot fileName False
-- start:
window <- makeWindow view stateRef
widgetShowAll window
mainGUI
makeWindow view stateRef = do
-- main window:
window <- windowNew
let ?pw = window in mdo
logo <- getDataFileName "data/logo48.png"
Control.Exception.catch (windowSetIconFromFile window logo)
(\e -> putStr ("Opening "++logo++" failed: ") >> print e)
windowSetTitle window "Fenfire"
windowSetDefaultSize window 800 550
-- textview for editing:
textView <- textViewNew
textViewSetAcceptsTab textView False
textViewSetWrapMode textView WrapWordChar
-- this needs to be called whenever the node or its text changes:
let stateChanged (FenState { fsRotation = Rotation g n _r,
fsGraphModified=modified,
fsFilePath=filepath }) = do
buf <- textBufferNew Nothing
textBufferSetText buf (maybe "" id $ getText g n)
afterBufferChanged buf $ do
start <- textBufferGetStartIter buf
end <- textBufferGetEndIter buf
text <- textBufferGetText buf start end True
FenState { fsRotation = (Rotation g' n' r'),
fsFilePath = filepath' }
<- readIORef stateRef
let g'' = setText g' n text -- buf corresponds to n, not to n'
modifyIORef stateRef $ \s ->
s { fsRotation = Rotation g'' n' r', fsGraphModified=True }
updateActionSensitivity actionGroup True (filepath' /= "")
updateCanvas True
textViewSetBuffer textView buf
updateActionSensitivity actionGroup modified (filepath /= "")
-- canvas for view:
(canvas, updateCanvas, canvasAction) <-
vobCanvas stateRef view handleEvent handleAction
stateChanged lightGray 0.5
onFocusIn canvas $ \_event -> do
modifyIORef stateRef $ \s -> s { fsHasFocus = True }
windowAddAccelGroup window bindings
updateCanvas True
return True
onFocusOut canvas $ \_event -> do
modifyIORef stateRef $ \s -> s { fsHasFocus = False }
windowRemoveAccelGroup window bindings
updateCanvas True
return True
-- action widgets:
accelGroup <- uiManagerNew >>= uiManagerGetAccelGroup -- XXX Gtk2Hs
windowAddAccelGroup window accelGroup
-- bindings are active only when the canvas has the focus:
bindings <- uiManagerNew >>= uiManagerGetAccelGroup -- XXX Gtk2Hs
actionGroup <- actionGroupNew "main"
makeActions actionGroup accelGroup
makeBindings actionGroup bindings
actions <- actionGroupListActions actionGroup
forM_ actions $ \action -> do
name <- actionGetName action
onActionActivate action $ canvasAction name >> return ()
-- user interface widgets:
menubar <- menuBarNew
makeMenus actionGroup menubar
toolbar <- toolbarNew
makeToolbarItems actionGroup toolbar
-- layout:
canvasFrame <- frameNew
set canvasFrame [ containerChild := canvas
, frameShadowType := ShadowIn
]
textViewFrame <- frameNew
set textViewFrame [ containerChild := textView
, frameShadowType := ShadowIn
]
paned <- vPanedNew
panedAdd1 paned canvasFrame
panedAdd2 paned textViewFrame
vbox <- vBoxNew False 0
boxPackStart vbox menubar PackNatural 0
boxPackStart vbox toolbar PackNatural 0
boxPackStart vbox paned PackGrow 0
containerSetFocusChain vbox [toWidget paned]
set paned [ panedPosition := 380, panedChildResize textViewFrame := False ]
set window [ containerChild := vbox ]
-- start:
readIORef stateRef >>= stateChanged
widgetGrabFocus canvas
onDelete window $ \_event -> canvasAction "quit"
return window
makeAboutDialog :: (?pw :: Window) => IO AboutDialog
makeAboutDialog = do
dialog <- aboutDialogNew
logoFilename <- getDataFileName "data/logo.svg"
pixbuf <- Control.Exception.catch (pixbufNewFromFile logoFilename)
(\e -> return $ Left (undefined, show e))
logo <- case pixbuf of Left (_,msg) -> do
putStr ("Opening "++logoFilename++" failed: ")
putStrLn msg
return Nothing
Right pixbuf' -> return . Just =<<
pixbufScaleSimple pixbuf'
200 (floor (200*(1.40::Double)))
InterpHyper
set dialog [ aboutDialogName := "Fenfire"
, aboutDialogVersion := "alpha version"
, aboutDialogCopyright := "Licensed under GNU GPL v2 or later"
, aboutDialogComments :=
"An application for notetaking and RDF graph browsing."
, aboutDialogLogo := logo
, aboutDialogWebsite := "http://fenfire.org"
, aboutDialogAuthors := ["Benja Fallenstein", "Tuukka Hastrup"]
, windowTransientFor := ?pw
]
onResponse dialog $ \_response -> widgetHide dialog
return dialog
makeDialog :: (?pw :: Window) => String -> [(String, ResponseId)] ->
ResponseId -> IO Dialog
makeDialog title buttons preset = do
dialog <- dialogNew
set dialog [ windowTitle := title
, windowTransientFor := ?pw
, windowModal := True
, windowDestroyWithParent := True
, dialogHasSeparator := False
]
mapM_ (uncurry $ dialogAddButton dialog) buttons
dialogSetDefaultResponse dialog preset
return dialog
makeConfirmUnsavedDialog :: (?pw :: Window) => IO Dialog
makeConfirmUnsavedDialog = do
makeDialog "Confirm unsaved changes"
[("Discard changes", ResponseClose),
(stockCancel, ResponseCancel),
(stockSave, ResponseAccept)]
ResponseAccept
makeConfirmRevertDialog :: (?pw :: Window) => IO Dialog
makeConfirmRevertDialog = do
makeDialog "Confirm revert"
[(stockCancel, ResponseCancel),
(stockRevertToSaved,ResponseClose)]
ResponseCancel