[Fencommits] fenfire-hs: split Fenfire module
Benja Fallenstein
benja.fallenstein at gmail.com
Wed Feb 28 17:52:11 EET 2007
Wed Feb 28 17:51:45 EET 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* split Fenfire module
diff -rN -u old-fenfire-hs/Fenfire.fhs new-fenfire-hs/Fenfire.fhs
--- old-fenfire-hs/Fenfire.fhs 2007-02-28 17:52:11.000000000 +0200
+++ new-fenfire-hs/Fenfire.fhs 2007-02-28 17:52:11.000000000 +0200
@@ -25,8 +25,6 @@
import Utils
import RDF
-import Paths_fenfire (getDataFileName)
-
import qualified Raptor (filenameToTriples, uriToTriples,
triplesToFilename, filenameToURI, Identifier(..))
@@ -145,137 +143,6 @@
-vanishingView :: (?vs :: ViewSettings) => Int -> Int -> Color -> Color ->
- Color -> Color ->
- Color -> Color -> FenState -> Vob Node
-vanishingView depth maxnodes bgColor blurBgColor focusColor blurColor
- textColor blurTextColor
- state@(FenState {fsGraph=graph, fsPath=path, fsMark=mark,
- fsHasFocus=focus}) =
- let ?graph = graph in result where
- startRotation :: (?graph :: Graph) => Rotation
- startRotation = fsRotation state
- result :: (?graph :: Graph) => Vob Node
- result = 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, textColor)
- else Just (blurBgColor, blurColor, blurTextColor))
- 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 n1 _) dir = withDepthIncreased 1 $
- maybeDo (toPath rotation dir) $ \path'@(Path _ [Conn prop _ n2]) -> do
- let rotation' = fromPath (rev path')
- 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 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 node _) = do
- scale' <- getScale
- let f vob = case bg of Nothing -> vob
- Just c -> setFgColor fg $
- setBgColor c vob
- markColor = if node `Set.member` mark then Just (Color 1 0 0 1)
- else Nothing
- bg = combine (fmap (\(_,b,_) -> b) cols) markColor
- fg = maybe (Color 0 0 0 1) (\(_,_,c) -> c) cols
- 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 (a,_,_) -> frame a & 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)) &
- closePath
- placeVob $ ownSize $ scale #scale' $ keyVob node $ g $
- f (useBgColor (fill extents) & pad 5 (nodeView node)) &
- useFgColor (stroke extents)
-
- 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 }
-
-
-
presentationView :: (?vs :: ViewSettings) => View FenState Node
presentationView state = let ?graph = fsGraph state in result where
result :: (?graph :: Graph) => Vob Node
@@ -413,101 +280,6 @@
Raptor.triplesToFilename (map convert triples) namespaces fileName
putStrLn $ "Saved: " ++ fileName
-openFile :: (?vs :: ViewSettings) => FilePath ->
- IO (Maybe (Graph, FilePath))
-openFile 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 $ Just (graph, fileName)
- _ -> return Nothing
-
-saveFile :: Graph -> FilePath -> Bool -> IO (FilePath,Bool)
-saveFile 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 ".turtle" s = s
- | otherwise = s ++ ".turtle"
-
-confirmSave :: (?vs :: ViewSettings, ?pw :: Window,
- ?views :: Views, ?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 ()
-
-confirmString :: (?vs :: ViewSettings, ?pw :: Window) =>
- String -> String -> (String -> HandlerAction FenState) ->
- HandlerAction FenState
-confirmString title preset action = do
- (response,text) <- liftIO $ do
- dialog <- makeDialog title
- [(stockCancel, ResponseCancel),
- (stockApply, ResponseAccept)]
- ResponseAccept
- entry <- entryNew
- set entry [ entryText := preset, entryActivatesDefault := True ]
- widgetShow entry
- vBox <- dialogGetUpper dialog
- boxPackStart vBox entry PackNatural 0
- response' <- dialogRun dialog
- text' <- entryGetText entry
- widgetHide dialog
- return (response',text')
- case response of ResponseAccept -> action text
- _ -> return ()
-
newState :: Graph -> Path -> FilePath -> Bool -> FenState
newState graph path fp focus =
FenState graph path Set.empty fp False focus 0 rdfs_seeAlso ps [] []
@@ -528,534 +300,3 @@
fsUndo = (fsGraph s, fsPath s) : fsUndo s, fsRedo = []
} where f x = if x == m then n else x
-handleEvent :: (?vs :: ViewSettings, ?pw :: Window, ?views :: Views,
- ?uriMaker :: URIMaker) => Handler Event FenState
-handleEvent (Key { eventModifier=_mods, eventKeyName=key }) = do
- state <- get; let graph = fsGraph 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"
- "v" -> handleAction "chgview"
- "p" -> handleAction "resetprop"
- "O" -> handleAction "open"
- "S" -> do (fp',saved) <- liftIO $ saveFile graph fileName False
- let modified' = fsGraphModified state && not saved
- put $ state { fsFilePath = fp', fsGraphModified = modified' }
- _ -> unhandledEvent
-handleEvent _ = unhandledEvent
-
-handleAction :: (?vs :: ViewSettings, ?pw :: Window, ?views :: Views,
- ?uriMaker :: URIMaker) => Handler String FenState
-handleAction action = do
- state@(FenState { fsGraph = graph, fsPath = path, fsMark = mark,
- fsFilePath = filepath, fsGraphModified = modified,
- fsHasFocus=focus, fsProperty=prop
- }) <- get
- let ?graph = graph in do
- let rot@(Rotation node _) = fsRotation state
- b f x = maybeDo (f rot x) $ \rot' -> do
- putRotation rot'
- modify $ \s -> s { fsGraphModified = modified }
- n f x = do (graph', rot') <- liftIO (f x prop (graph, rot))
- putGraph graph'; putRotation rot'
- o f x = do put (f x state); setInterp True
- 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"-> o disconnect Neg ; "breakr"-> o disconnect Pos
- "rmlit" -> putGraph (delLit node graph)
- "mark" -> putMark $ toggleMark node mark
- "new" -> confirmSave modified $ do
- (g', path') <- liftIO newGraph
- put $ newState g' path' "" focus
- "open" -> confirmSave modified $ do
- result <- liftIO $ openFile filepath
- maybeDo result $ \(g',fp') -> do
- uri <- liftM URI $ liftIO $ Raptor.filenameToURI fp'
- let ts = containsInfoTriples uri g'
- g'' = foldr insertVirtual g' ts
- put $ newState g'' (findStartPath uri g'') fp' focus
- "loadURI" -> case node of
- URI uri -> do
- g <- liftIO $ loadGraph uri
- let ts = containsInfoTriples (URI uri) g
- g' = foldr insertVirtual
- (mergeGraphs graph g) ts
- s' = state {fsGraph=g',
- fsUndo=(graph,path):fsUndo state,
- fsRedo=[]}
- put s'
- _ -> unhandledEvent
- "revert" | filepath /= "" -> confirmRevert modified $ do
- g' <- liftIO $ loadGraph filepath
- gNode <- liftM URI $ liftIO $ Raptor.filenameToURI filepath
- let g'' = foldr insertVirtual g' $ containsInfoTriples gNode g'
- put $ newState g'' (findStartPath gNode g'') filepath focus
- "save" | filepath /= "" -> do
- liftIO $ saveGraph graph filepath
- modify $ \s -> s { fsGraphModified = False }
- | otherwise -> handleAction "saveas"
- "saveas"-> do
- (fp',saved) <- liftIO $ saveFile graph filepath True
- let modified' = modified && not saved
- modify $ \s -> s { fsFilePath = fp', fsGraphModified = modified' }
- "quit" -> do confirmSave modified $ liftIO mainQuit
- "about" -> liftIO $ makeAboutDialog >>= widgetShow
- "chgview" -> do put $ state { fsView = (fsView state + 1) `mod`
- (length ?views) }
- setInterp True
- "addprop" -> do let uri = case node of URI x -> x
- _ -> ""
- confirmString "Add property" uri $ \uri' ->
- when (uri' /= "") $ do
- let prop' = URI uri'
- props = fsProperties state
- put $ state { fsProperty = prop',
- fsProperties = Set.insert prop' props }
- "resetprop" -> when (fsProperty state /= rdfs_seeAlso) $
- put $ state { fsProperty = rdfs_seeAlso }
- "changeURI" -> case node of
- URI uri -> confirmString "New URI" uri $ \uri' ->
- put $ stateReplaceNode (URI uri) (URI uri') state
- _ -> unhandledEvent
- "undo" | (graph',path'):undos <- fsUndo state -> do
- put state {fsGraph=graph', fsPath=path',
- fsUndo=undos, fsRedo=(graph,path):fsRedo state}
- setInterp True
- "redo" | (graph',path'):redos <- fsRedo state -> do
- put state {fsGraph=graph', fsPath=path',
- fsUndo=(graph,path):fsUndo state, fsRedo=redos}
- setInterp True
- _ -> do liftIO $ putStrLn $ "Unhandled action: " ++ action
- unhandledEvent
- where putGraph g = do modify $ \s ->
- s { fsGraph=g, fsGraphModified=True,
- fsUndo=(fsGraph s, fsPath s):fsUndo s,
- fsRedo=[]}
- setInterp True
- putRotation rot = do modify $ \s -> s { fsPath = toPath' rot }
- setInterp True
- putMark mk = do modify $ \state -> state { fsMark=mk }
- delLit n graph = deleteAll n rdfs_label graph
-
-makeActions actionGroup accelGroup = do
- let actionentries =
- [ ( "new" , Nothing, stockNew , Nothing )
- , ( "open" , Nothing, stockOpen , Nothing )
- , ( "save" , Nothing, stockSave , Nothing )
- , ( "saveas" , Nothing, stockSaveAs , Just "<Ctl><Shift>S" )
- , ( "revert" , Nothing, stockRevertToSaved , Nothing )
- , ( "quit" , Nothing, stockQuit , Nothing )
- , ( "about" , Nothing, stockAbout , Nothing )
- , ( "loadURI", Just "_Load node's URI",
- stockGoForward , Just "<Ctl>L" )
- , ( "undo" , Nothing, stockUndo , Just "<Ctl>Z" )
- , ( "redo" , Nothing, stockRedo , Just "<Ctl><Shift>Z" )
- ]
- forM actionentries $ \(name,label',stock,accel) -> do
- action <- actionNew name label' Nothing (Just stock)
- actionGroupAddActionWithAccel actionGroup action accel
- actionSetAccelGroup action accelGroup
-
-updateActions actionGroup stateRef = do
- state <- readIORef stateRef
- let readable = fsFilePath state /= ""
- modified = fsGraphModified state
- view = fst $ ?views !! (fsView state)
-
- Just save <- actionGroupGetAction actionGroup "save"
- actionSetSensitive save modified
- Just revert <- actionGroupGetAction actionGroup "revert"
- actionSetSensitive revert (modified && readable)
- Just undo <- actionGroupGetAction actionGroup "undo"
- actionSetSensitive undo (not $ null $ fsUndo state)
- Just redo <- actionGroupGetAction actionGroup "redo"
- actionSetSensitive redo (not $ null $ fsRedo state)
- Just changeView <- actionGroupGetAction actionGroup view
- toggleActionSetActive (castToToggleAction changeView) True
-
-updatePropMenu propmenu actionGroup stateRef updateCanvas = do
- state <- readIORef stateRef
- Just addProp <- actionGroupGetAction actionGroup "addprop"
-
- menu <- menuNew
- forM (Set.toAscList $ fsProperties state) $ \prop -> do
- item <- let ?graph = fsGraph state
- in menuItemNewWithLabel $ getTextOrURI prop
- onActivateLeaf item $ do
- modifyIORef stateRef $ \state' -> state' {fsProperty=prop}
- updateCanvas False
- menuShellAppend menu item
- widgetShow item
- sep <- separatorMenuItemNew
- menuShellAppend menu sep
- widgetShow sep
- item <- actionCreateMenuItem addProp
- menuShellAppend menu $ castToMenuItem item
-
- menuItemSetSubmenu propmenu menu
-
-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" )
- , ("addprop", Just "_Add property" ,
- stockAdd , Just "<Ctl>P" )
- , ("changeURI", Just "Change node's _URI" ,
- stockRefresh , Just "u" )
- ]
- forM bindingentries $ \(name,label',stock,accel) -> do
- action <- actionNew name label' Nothing (Just stock)
- actionGroupAddActionWithAccel actionGroup action accel
- actionSetAccelGroup action bindings
-
-makeMenus actionGroup root propmenu = addAll root menu where
- menu = [m "_File" [a "new", a "open", a "loadURI", sep,
- a "save", a "saveas", a "revert", sep,
- a "quit"],
- m "_Edit" [a "undo", a "redo", sep,
- return propmenu, sep,
- a "noder", a "nodel", sep,
- a "breakr", a "breakl", sep,
- a "mark", a "connr", a "connl", sep,
- a "changeURI", a "rmlit"],
- m "_View" (map (a . fst) ?views),
- m "_Help" [a "about"]]
- addAll parent items = mapM_ (menuShellAppend parent) =<< sequence items
- m :: String -> [IO MenuItem] -> IO MenuItem
- m name children = do item <- menuItemNewWithMnemonic name
- menu' <- menuNew
- addAll menu' children
- menuItemSetSubmenu item menu'
- return item
- sep = liftM castToMenuItem separatorMenuItemNew
- a name = do Just action <- actionGroupGetAction actionGroup name
- item <- actionCreateMenuItem action
- return (castToMenuItem item)
-
-makeToolbarItems actionGroup toolbar = do
- forM_ ["new", "open", "save", "", "undo", "redo",""] $ \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
-
- -- initial state:
-
- args <- initGUI
-
- window <- windowNew
- style <- widgetGetStyle window
-
- bgColor <- styleGetBackground style StateSelected
- blurBgColor <- styleGetBackground style StateActive
- focusColor <- styleGetBase style StateSelected
- blurColor <- styleGetBase style StateActive
- textColor <- styleGetText style StateSelected
- blurTextColor <- styleGetText style StateActive
-
- canvasBgColor <- styleGetBackground style StateNormal
-
- let alpha x (Color r g b a) = Color r g b (x*a)
-
- let ?vs = ViewSettings { hiddenProps=[rdfs_label], maxCenter=3 }
- ?uriMaker = uriMaker in let
- ?views = [("Wheel view", vanishingView 20 30
- (alpha 0.7 $ fromGtkColor bgColor)
- (alpha 0.7 $ fromGtkColor blurBgColor)
- (fromGtkColor focusColor) (fromGtkColor blurColor)
- (fromGtkColor textColor) (fromGtkColor blurTextColor)),
- ("Presentation view", presentationView)] in do
-
- let view s = snd (?views !! fsView s) s
-
- stateRef <- case args of
- [] -> do
- (g, rot) <- newGraph
- newIORef $ newState g rot "" False
- xs -> do
- let f x | Data.List.isPrefixOf "http:" x = return x
- | otherwise = canonicalizePath x
- fileName:fileNames <- mapM f xs
- g' <- loadGraph fileName
- gs <- mapM loadGraph fileNames
- uri <- Raptor.filenameToURI fileName
- uris <- mapM Raptor.filenameToURI fileNames
- let ts = concatMap (uncurry containsInfoTriples) $
- (URI uri, g') : zip (map URI uris) gs
- graph = foldr insertVirtual (foldl mergeGraphs g' gs) ts
- newIORef $ newState graph (findStartPath (URI uri) graph) fileName False
-
- -- start:
-
- makeWindow window canvasBgColor view stateRef
- widgetShowAll window
-
- mainGUI
-
-makeWindow window canvasBgColor view stateRef = do
-
- -- main window:
-
- let ?pw = window in mdo
- logo <- getDataFileName "data/icon16.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 _ state@(FenState { fsPath=Path n _, fsGraph=g }) = do
- buf <- textBufferNew Nothing
- textBufferSetText buf (let ?graph=g in maybe "" id $ getText n)
- afterBufferChanged buf $ do
- start <- textBufferGetStartIter buf
- end <- textBufferGetEndIter buf
- text <- textBufferGetText buf start end True
- s@(FenState { fsGraph = g' }) <- readIORef stateRef
- let g'' = setText n text g' -- buf corresponds to n, not to n'
-
- writeIORef stateRef $
- s { fsGraph=g'', fsGraphModified=True, fsRedo=[],
- fsUndo=(fsGraph s, fsPath s):(fsUndo s) }
- updateActions actionGroup stateRef
- updateCanvas True
-
- textViewSetBuffer textView buf
- updatePropMenu propmenu actionGroup stateRef updateCanvas
- New.listStoreClear propList
- forM_ (Set.toAscList $ fsProperties state) $ \prop ->
- let ?graph = g in
- New.listStoreAppend propList (prop, getTextOrURI prop)
- let activeIndex = Data.List.elemIndex (fsProperty state)
- (Set.toAscList $ fsProperties state)
- maybe (return ()) (New.comboBoxSetActive combo) activeIndex
-
- updateActions actionGroup stateRef
-
- -- canvas for view:
-
- (canvas, updateCanvas, canvasAction) <-
- vobCanvas stateRef view handleEvent handleAction
- stateChanged (fromGtkColor canvasBgColor) 0.5
-
- onFocusIn canvas $ \_event -> do
- modifyIORef stateRef $ \s -> s { fsHasFocus = True }
- forM_ bindingActions $ actionConnectAccelerator
- updateCanvas True
- return True
- onFocusOut canvas $ \_event -> do
- modifyIORef stateRef $ \s -> s { fsHasFocus = False }
- forM_ bindingActions $ actionDisconnectAccelerator
- updateCanvas True
- return True
-
- -- action widgets:
-
- accelGroup <- accelGroupNew
- windowAddAccelGroup window accelGroup
- -- bindings are active only when the canvas has the focus:
- bindings <- accelGroupNew
- windowAddAccelGroup window bindings
- -- fake bindings aren't used
- fake <- accelGroupNew
-
- actionGroup <- actionGroupNew "main"
- bindingGroup <- actionGroupNew "bindings"
-
- makeActions actionGroup accelGroup
- makeBindings bindingGroup bindings
- makeBindings actionGroup fake
-
- actions <- actionGroupListActions actionGroup
- bindingActions <- actionGroupListActions bindingGroup
-
- forM_ (actions ++ bindingActions) $ \action -> do
- name <- actionGetName action
- onActionActivate action $ canvasAction name >> return ()
-
- viewActs <- forM (zip [0..] ?views) $ \(index, (name, _view)) -> do
- action <- radioActionNew name name Nothing Nothing index
- actionGroupAddAction actionGroup action
- onActionActivate action $ do
- i <- radioActionGetCurrentValue action
- state <- readIORef stateRef
- when (i /= fsView state) $ do
- writeIORef stateRef $ state { fsView = i }
- updateCanvas True
- return action
-
- forM_ (tail viewActs) $ \x -> radioActionSetGroup x (head viewActs)
- toggleActionSetActive (toToggleAction $ head viewActs) True
-
- -- user interface widgets:
-
- menubar <- menuBarNew
- propmenu <- menuItemNewWithMnemonic "Set _property"
- makeMenus actionGroup menubar propmenu
-
- toolbar <- toolbarNew
- makeToolbarItems actionGroup toolbar
-
- propList <- New.listStoreNew []
- combo <- New.comboBoxNew
- set combo [ New.comboBoxModel := Just propList
- , New.comboBoxFocusOnClick := False ]
- renderer <- New.cellRendererTextNew
- New.cellLayoutPackStart combo renderer True
- New.cellLayoutSetAttributes combo renderer propList $ \row ->
- [ New.cellText := snd row ]
- New.onChanged combo $ do
- active <- New.comboBoxGetActive combo
- case active of
- Nothing -> return ()
- Just i -> do
- (prop,_name) <- listStoreGetValue propList i
- state' <- readIORef stateRef
- writeIORef stateRef $ state' {fsProperty=prop}
- when (fsProperty state' /= prop) $ updateCanvas False
-
- comboLabel <- labelNew (Just "Property: ")
-
- comboVBox <- hBoxNew False 0
- boxPackStart comboVBox comboLabel PackNatural 0
- boxPackStart comboVBox combo PackNatural 0
-
- comboAlign <- alignmentNew 0.5 0.5 1 0
- containerAdd comboAlign comboVBox
-
- combotool <- toolItemNew
- containerAdd combotool comboAlign
- toolbarInsert toolbar combotool (-1)
-
- sepItem <- separatorToolItemNew
- toolbarInsert toolbar sepItem (-1)
-
- Just addpropAction <- actionGroupGetAction actionGroup "addprop"
- addpropItem <- actionCreateToolItem addpropAction
- toolbarInsert toolbar (castToToolItem addpropItem) (-1)
-
- -- 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:
-
- startState <- readIORef stateRef
- stateChanged (startState { fsProperties = Set.empty }) startState
-
- widgetGrabFocus canvas
-
- onDelete window $ \_event -> canvasAction "quit"
-
-
-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
diff -rN -u old-fenfire-hs/Fenfire.hs new-fenfire-hs/Fenfire.hs
--- old-fenfire-hs/Fenfire.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenfire-hs/Fenfire.hs 2007-02-28 17:52:11.000000000 +0200
@@ -0,0 +1,481 @@
+-- GENERATED file. Edit the ORIGINAL Fenfire.fhs instead.
+{-# LINE 1 "Fenfire.fhs" #-}
+{-# OPTIONS_GHC -fth #-} {-# OPTIONS_GHC -fallow-overlapping-instances -fimplicit-params #-}
+ module Fenfire where
+{-# LINE 1 "Fenfire.fhs" #-}
+import qualified FunctorSugar
+{-# LINE 22 "Fenfire.fhs" #-}
+import qualified Cache
+{-# LINE 23 "Fenfire.fhs" #-}
+import Cairo hiding (rotate, Path)
+{-# LINE 24 "Fenfire.fhs" #-}
+import Vobs
+{-# LINE 25 "Fenfire.fhs" #-}
+import Utils
+{-# LINE 26 "Fenfire.fhs" #-}
+import RDF
+{-# LINE 28 "Fenfire.fhs" #-}
+import qualified Raptor (filenameToTriples, uriToTriples,
+ triplesToFilename, filenameToURI, Identifier(..))
+{-# LINE 31 "Fenfire.fhs" #-}
+import qualified Data.Map as Map
+{-# LINE 32 "Fenfire.fhs" #-}
+import qualified Data.Set as Set
+{-# LINE 33 "Fenfire.fhs" #-}
+import qualified Data.Tree as Tree
+{-# LINE 34 "Fenfire.fhs" #-}
+import Data.List (intersperse)
+{-# LINE 35 "Fenfire.fhs" #-}
+import qualified Data.List
+{-# LINE 36 "Fenfire.fhs" #-}
+import Data.Set (Set)
+{-# LINE 37 "Fenfire.fhs" #-}
+import Data.IORef
+{-# LINE 38 "Fenfire.fhs" #-}
+import Data.Maybe (fromMaybe, fromJust, isJust, isNothing,
+ catMaybes)
+{-# LINE 39 "Fenfire.fhs" #-}
+import Data.Monoid (Monoid(mempty, mconcat), Dual(Dual), getDual)
+{-# LINE 41 "Fenfire.fhs" #-}
+import Control.Applicative
+{-# LINE 42 "Fenfire.fhs" #-}
+import qualified Control.Exception
+{-# LINE 43 "Fenfire.fhs" #-}
+import Control.Monad (when, guard, mplus, msum, liftM, join)
+{-# LINE 44 "Fenfire.fhs" #-}
+import Control.Monad.Reader (ReaderT, runReaderT, local, ask, asks)
+{-# LINE 45 "Fenfire.fhs" #-}
+import Control.Monad.State (StateT, get, gets, modify, put,
+ execStateT)
+{-# LINE 46 "Fenfire.fhs" #-}
+import Control.Monad.Trans (lift, liftIO)
+{-# LINE 47 "Fenfire.fhs" #-}
+import Control.Monad.Writer (Writer, execWriter, tell)
+{-# LINE 49 "Fenfire.fhs" #-}
+import GtkFixes
+{-# LINE 50 "Fenfire.fhs" #-}
+import Graphics.UI.Gtk hiding (Color, get, disconnect, fill,
+ actionNew, widgetGetStyle, styleGetForeground, styleGetBackground,
+ styleGetLight, styleGetMiddle, styleGetDark, styleGetText,
+ styleGetBase, styleGetAntiAliasing)
+{-# LINE 58 "Fenfire.fhs" #-}
+import Graphics.UI.Gtk.ModelView as New
+{-# LINE 60 "Fenfire.fhs" #-}
+import qualified Network.URI
+{-# LINE 62 "Fenfire.fhs" #-}
+import System.Directory (canonicalizePath)
+{-# LINE 63 "Fenfire.fhs" #-}
+import System.Environment (getArgs, getProgName)
+{-# LINE 64 "Fenfire.fhs" #-}
+import System.Mem.StableName
+{-# LINE 65 "Fenfire.fhs" #-}
+import System.Random (randomRIO)
+
+{-# LINE 67 "Fenfire.fhs" #-}
+data ViewSettings = ViewSettings{hiddenProps :: [Node],
+ maxCenter :: Int}
+
+{-# LINE 68 "Fenfire.fhs" #-}
+data FenState = FenState{fsGraph :: Graph, fsPath :: Path,
+ fsMark :: Mark, fsFilePath :: FilePath, fsGraphModified :: Bool,
+ fsHasFocus :: Bool, fsView :: Int, fsProperty :: Node,
+ fsProperties :: Set Node, fsUndo :: [(Graph, Path)],
+ fsRedo :: [(Graph, Path)]}
+
+{-# LINE 74 "Fenfire.fhs" #-}
+fsNode :: FenState -> Node
+{-# LINE 75 "Fenfire.fhs" #-}
+fsNode (FenState{fsPath = Path node _}) = node
+
+{-# LINE 77 "Fenfire.fhs" #-}
+fsRotation ::
+ (?vs :: ViewSettings, ?graph :: Graph) => FenState -> Rotation
+{-# LINE 78 "Fenfire.fhs" #-}
+fsRotation = fromPath . fsPath
+
+{-# LINE 80 "Fenfire.fhs" #-}
+type Views = [(String, View FenState Node)]
+
+{-# LINE 82 "Fenfire.fhs" #-}
+data Rotation = Rotation Node Int
+ deriving (Eq, Show)
+
+{-# LINE 84 "Fenfire.fhs" #-}
+fromPath ::
+ (?vs :: ViewSettings, ?graph :: Graph) => Path -> Rotation
+{-# LINE 85 "Fenfire.fhs" #-}
+fromPath path@(Path node (Conn _ dir _ : _))
+ = fromMaybe (Rotation node 0) $
+ do let {-# LINE 86 "Fenfire.fhs" #-}
+ c = conns node dir
+ i <- Data.List.elemIndex path c
+ return $ Rotation node (i - min (length c `div` 2) (maxCenter ?vs))
+{-# LINE 89 "Fenfire.fhs" #-}
+fromPath (Path node []) = Rotation node 0
+
+{-# LINE 91 "Fenfire.fhs" #-}
+toPath ::
+ (?vs :: ViewSettings, ?graph :: Graph) =>
+ Rotation -> Dir -> Maybe Path
+{-# LINE 93 "Fenfire.fhs" #-}
+toPath (Rotation node r) dir
+ = let {-# LINE 93 "Fenfire.fhs" #-}
+ c = conns node dir
+ in c !? (min (length c `div` 2) (maxCenter ?vs) + r)
+{-# LINE 96 "Fenfire.fhs" #-}
+toPath' rot@(Rotation node _)
+ = head $
+ catMaybes [toPath rot Pos, toPath rot Neg, Just $ Path node []]
+
+{-# LINE 99 "Fenfire.fhs" #-}
+connsCache :: Cache.Cache (StableName Graph, (Node, Dir)) [Path]
+{-# LINE 100 "Fenfire.fhs" #-}
+connsCache = Cache.newCache 10000
+{-# LINE 102 "Fenfire.fhs" #-}
+dc_date = URI "dc:date"
+
+{-# LINE 104 "Fenfire.fhs" #-}
+conns ::
+ (?vs :: ViewSettings, ?graph :: Graph) => Node -> Dir -> [Path]
+{-# LINE 105 "Fenfire.fhs" #-}
+conns node dir
+ = Cache.cached (Cache.byAddress ?graph, (node, dir)) connsCache
+ result
+ where {-# LINE 107 "Fenfire.fhs" #-}
+ result
+ = map (\ (prop, node') -> Path node [Conn prop dir node']) sorted
+ {-# LINE 108 "Fenfire.fhs" #-}
+ sorted = Data.List.sortBy cmp' list
+ {-# LINE 109 "Fenfire.fhs" #-}
+ list
+ = [(p, n) | (p, s) <- Map.toList $ getConns ?graph node dir,
+ not (p `elem` hiddenProps ?vs), n <- Set.toList s]
+ {-# LINE 111 "Fenfire.fhs" #-}
+ cmp n1 n2 | p n1 && p n2 = compare (f n1) (f n2)
+ where {-# LINE 112 "Fenfire.fhs" #-}
+ p n = hasConn ?graph n dc_date Pos
+ {-# LINE 112 "Fenfire.fhs" #-}
+ f n = getOne ?graph n dc_date Pos
+ {-# LINE 113 "Fenfire.fhs" #-}
+ cmp n1 n2 = compare (getText n1) (getText n2)
+ {-# LINE 114 "Fenfire.fhs" #-}
+ cmp' (p1, n1) (p2, n2) = catOrds (cmp p1 p2) (cmp n1 n2)
+ {-# LINE 115 "Fenfire.fhs" #-}
+ catOrds (EQ) o = o
+ {-# LINE 115 "Fenfire.fhs" #-}
+ catOrds o _ = o
+
+{-# LINE 117 "Fenfire.fhs" #-}
+rotate ::
+ (?vs :: ViewSettings, ?graph :: Graph) =>
+ Rotation -> Int -> Maybe Rotation
+{-# LINE 119 "Fenfire.fhs" #-}
+rotate (Rotation n r) dir
+ = let {-# LINE 119 "Fenfire.fhs" #-}
+ rot = Rotation n (r + dir)
+ in
+ do guard $ any isJust [toPath rot d | d <- [Pos, Neg]]
+ return rot
+
+{-# LINE 122 "Fenfire.fhs" #-}
+move ::
+ (?vs :: ViewSettings, ?graph :: Graph) =>
+ Rotation -> Dir -> Maybe Rotation
+{-# LINE 124 "Fenfire.fhs" #-}
+move rot dir
+ = do path <- toPath rot dir
+ return $ fromPath (rev path)
+
+{-# LINE 127 "Fenfire.fhs" #-}
+getText :: (?graph :: Graph) => Node -> Maybe String
+{-# LINE 128 "Fenfire.fhs" #-}
+getText n = fmap f $ getOne ?graph n rdfs_label Pos
+ where {-# LINE 129 "Fenfire.fhs" #-}
+ f (PlainLiteral s) = s
+ {-# LINE 129 "Fenfire.fhs" #-}
+ f _ = error "getText argh"
+
+{-# LINE 131 "Fenfire.fhs" #-}
+getTextOrURI :: (?graph :: Graph) => Node -> String
+{-# LINE 132 "Fenfire.fhs" #-}
+getTextOrURI n
+ = fromMaybe (showNode (graphNamespaces ?graph) n) (getText n)
+
+{-# LINE 134 "Fenfire.fhs" #-}
+setText :: Node -> String -> Endo Graph
+{-# LINE 135 "Fenfire.fhs" #-}
+setText n t = update (n, rdfs_label, PlainLiteral t)
+
+{-# LINE 137 "Fenfire.fhs" #-}
+nodeView :: (?graph :: Graph) => Node -> Vob Node
+{-# LINE 138 "Fenfire.fhs" #-}
+nodeView n = useFgColor $ multiline False 20 $ getTextOrURI n
+
+{-# LINE 140 "Fenfire.fhs" #-}
+propView :: (?graph :: Graph) => Node -> Vob Node
+{-# LINE 141 "Fenfire.fhs" #-}
+propView n
+ = (useFadeColor $ fill extents) &
+ (pad 5 $ useFgColor $ label $ getTextOrURI n)
+
+{-# LINE 146 "Fenfire.fhs" #-}
+presentationView :: (?vs :: ViewSettings) => View FenState Node
+{-# LINE 147 "Fenfire.fhs" #-}
+presentationView state = let ?graph = fsGraph state in result
+ where
+ {-# LINE 148 "Fenfire.fhs" #-}
+ result :: (?graph :: Graph) => Vob Node
+ {-# LINE 149 "Fenfire.fhs" #-}
+ result = cursor & vob
+ where {-# LINE 150 "Fenfire.fhs" #-}
+ node = fsNode state
+ {-# LINE 151 "Fenfire.fhs" #-}
+ children = map getPos (conns node Pos)
+ {-# LINE 152 "Fenfire.fhs" #-}
+ selected = fmap (getSide Pos) (toPath (fsRotation state) Pos)
+ {-# LINE 153 "Fenfire.fhs" #-}
+ f sc n
+ = keyVob n $ useFgColor $ pad 5 $ scaleVob sc $ multiline True 70 $
+ getTextOrURI n
+ {-# LINE 155 "Fenfire.fhs" #-}
+ cursor
+ = flip (maybe mempty) selected $
+ \ n ->
+ showAtKey n $ keyVob (PlainLiteral "CURSOR") $ rectBox mempty
+ {-# LINE 157 "Fenfire.fhs" #-}
+ space = changeSize (const (0, 20)) mempty
+ {-# LINE 158 "Fenfire.fhs" #-}
+ vob
+ = pad 30 $ vbox $ intersperse space $ f 3 node : map (f 2) children
+
+{-# LINE 162 "Fenfire.fhs" #-}
+tryMove ::
+ (?vs :: ViewSettings, ?graph :: Graph) =>
+ Rotation -> Dir -> Maybe Rotation
+{-# LINE 164 "Fenfire.fhs" #-}
+tryMove rot@(Rotation n r) dir = maybe rot' Just (move rot dir)
+ where {-# LINE 165 "Fenfire.fhs" #-}
+ rot'
+ | r == nearest = Nothing
+ | otherwise = Just $ Rotation n nearest
+ {-# LINE 167 "Fenfire.fhs" #-}
+ nearest
+ | r > 0 = len - 1 - min (len `div` 2) (maxCenter ?vs)
+ | otherwise = 0 - min (len `div` 2) (maxCenter ?vs)
+ {-# LINE 169 "Fenfire.fhs" #-}
+ len = (length $ conns n dir)
+
+{-# LINE 171 "Fenfire.fhs" #-}
+type URIMaker = (String, IORef Integer)
+
+{-# LINE 173 "Fenfire.fhs" #-}
+newURIMaker :: IO URIMaker
+{-# LINE 174 "Fenfire.fhs" #-}
+newURIMaker
+ = do rand <- sequence [randomRIO (0, 63) | _ <- [1 .. 27 :: Int]]
+ let {-# LINE 175 "Fenfire.fhs" #-}
+ chars = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "+-"
+ ref <- newIORef 1
+ return ("urn:urn-5:" ++ map (chars !!) rand, ref)
+
+{-# LINE 179 "Fenfire.fhs" #-}
+newURI :: (?uriMaker :: URIMaker) => IO Node
+{-# LINE 180 "Fenfire.fhs" #-}
+newURI
+ = do let {-# LINE 180 "Fenfire.fhs" #-}
+ (base, ref) = ?uriMaker
+ i <- readIORef ref
+ writeIORef ref (i + 1)
+ return $ URI (base ++ ":_" ++ show i)
+
+{-# LINE 184 "Fenfire.fhs" #-}
+newNode ::
+ (?vs :: ViewSettings, ?uriMaker :: URIMaker) =>
+ Dir -> Node -> EndoM IO (Graph, Rotation)
+{-# LINE 186 "Fenfire.fhs" #-}
+newNode dir prop (graph, Rotation node _)
+ = do node' <- newURI
+ let ?graph =
+ insert (triple dir (node, prop, node')) $
+ insert (node', rdfs_label, PlainLiteral "") graph
+ in
+ return (?graph, fromPath (Path node' [Conn prop (rev dir) node]))
+
+{-# LINE 192 "Fenfire.fhs" #-}
+connect :: (?vs :: ViewSettings) => Dir -> Endo FenState
+{-# LINE 193 "Fenfire.fhs" #-}
+connect _ state | Set.null (fsMark state) = state
+{-# LINE 194 "Fenfire.fhs" #-}
+connect dir state
+ = let {-# LINE 195 "Fenfire.fhs" #-}
+ nodes = Set.toList (fsMark state)
+ {-# LINE 195 "Fenfire.fhs" #-}
+ prop = fsProperty state
+ in
+ let ?graph =
+ foldr (\ n -> insert $ triple dir (fsNode state, prop, n))
+ (fsGraph state)
+ nodes
+ in
+ state{fsPath = (Path (fsNode state) [Conn prop dir (head nodes)]),
+ fsGraph = ?graph, fsMark = Set.empty, fsGraphModified = True,
+ fsUndo = (fsGraph state, fsPath state) : fsUndo state, fsRedo = []}
+
+{-# LINE 203 "Fenfire.fhs" #-}
+disconnect :: (?vs :: ViewSettings) => Dir -> Endo FenState
+{-# LINE 204 "Fenfire.fhs" #-}
+disconnect dir state
+ = let ?graph = fsGraph state in
+ let {-# LINE 205 "Fenfire.fhs" #-}
+ rot = fsRotation state
+ in
+ case toPath rot dir of
+ Nothing -> state
+ Just path -> let {-# LINE 209 "Fenfire.fhs" #-}
+ path'
+ = fromMaybe (Path (fsNode state) []) $
+ msum
+ [flip toPath xdir =<< rotate rot ydir | xdir <- [Neg, Pos],
+ ydir <- [- 1, 1]]
+ {-# LINE 212 "Fenfire.fhs" #-}
+ triples = pathToTriples path
+ {-# LINE 213 "Fenfire.fhs" #-}
+ graph' = foldr delete (fsGraph state) triples
+ in
+ state{fsGraph = graph', fsPath = path', fsGraphModified = True,
+ fsUndo = (fsGraph state, fsPath state) : fsUndo state, fsRedo = []}
+
+{-# LINE 219 "Fenfire.fhs" #-}
+type Mark = Set Node
+
+{-# LINE 221 "Fenfire.fhs" #-}
+toggleMark :: Node -> Endo Mark
+{-# LINE 222 "Fenfire.fhs" #-}
+toggleMark n mark
+ | n `Set.member` mark = Set.delete n mark
+ | otherwise = Set.insert n mark
+
+{-# LINE 225 "Fenfire.fhs" #-}
+newGraph :: (?uriMaker :: URIMaker) => IO (Graph, Path)
+{-# LINE 226 "Fenfire.fhs" #-}
+newGraph
+ = do home <- newURI
+ let {-# LINE 228 "Fenfire.fhs" #-}
+ graph = listToGraph [(home, rdfs_label, PlainLiteral "")]
+ return (graph, Path home [])
+
+{-# LINE 231 "Fenfire.fhs" #-}
+findStartPath :: (?vs :: ViewSettings) => Node -> Graph -> Path
+{-# LINE 232 "Fenfire.fhs" #-}
+findStartPath self g = let ?graph = g in result
+ where
+ {-# LINE 233 "Fenfire.fhs" #-}
+ result :: (?graph :: Graph) => Path
+ {-# LINE 234 "Fenfire.fhs" #-}
+ result = head $ catMaybes $ startNode : topic : triples
+ where {-# LINE 236 "Fenfire.fhs" #-}
+ startNode = fmap getRot' $ getTriple self ffv_startNode
+ {-# LINE 237 "Fenfire.fhs" #-}
+ topic = fmap getRot' $ getTriple self foaf_primaryTopic
+ {-# LINE 238 "Fenfire.fhs" #-}
+ triples = map (Just . getRot) $ graphToList g
+ {-# LINE 240 "Fenfire.fhs" #-}
+ getTriple s p = fmap (\ o -> (s, p, o)) $ getOne g s p Pos
+ {-# LINE 241 "Fenfire.fhs" #-}
+ getRot (s, p, o) = Path s [Conn p Pos o]
+ {-# LINE 242 "Fenfire.fhs" #-}
+ getRot' (s, p, o) = Path o [Conn p Neg s]
+ {-# LINE 244 "Fenfire.fhs" #-}
+ ffv_startNode = URI "http://fenfire.org/rdf-v/2003/05/ff#startNode"
+ {-# LINE 245 "Fenfire.fhs" #-}
+ foaf_primaryTopic = URI "http://xmlns.com/foaf/0.1/primaryTopic"
+
+{-# LINE 247 "Fenfire.fhs" #-}
+containsInfoTriples ::
+ (?vs :: ViewSettings) => Node -> Graph -> [Triple]
+{-# LINE 248 "Fenfire.fhs" #-}
+containsInfoTriples s g = [(s, p, o) | o <- os, o /= s]
+ where {-# LINE 249 "Fenfire.fhs" #-}
+ p = URI "ex:containsInformationAbout"
+ {-# LINE 250 "Fenfire.fhs" #-}
+ triples = graphToList g
+ {-# LINE 251 "Fenfire.fhs" #-}
+ [subjects, objects] = for [subject, object] $ \ f -> map f triples
+ {-# LINE 252 "Fenfire.fhs" #-}
+ os
+ = Set.toAscList $ foldr Set.delete (Set.fromList subjects) objects
+
+{-# LINE 254 "Fenfire.fhs" #-}
+loadGraph :: FilePath -> IO Graph
+{-# LINE 255 "Fenfire.fhs" #-}
+loadGraph fileName
+ = do let {-# LINE 258 "Fenfire.fhs" #-}
+ convert (s, p, o) = (f s, f p, f o)
+ {-# LINE 259 "Fenfire.fhs" #-}
+ f (Raptor.Uri s) = URI s
+ {-# LINE 260 "Fenfire.fhs" #-}
+ f (Raptor.Literal s) = PlainLiteral s
+ {-# LINE 261 "Fenfire.fhs" #-}
+ f (Raptor.Blank s) = URI $ "blank:" ++ s
+ (raptorTriples, namespaces) <- if
+ Data.List.isPrefixOf "http:" fileName then
+ Raptor.uriToTriples fileName Nothing else
+ Raptor.filenameToTriples fileName Nothing
+ triples <- return $ map convert raptorTriples
+ return $
+ foldr (uncurry addNamespace) (listToGraph triples) namespaces
+
+{-# LINE 268 "Fenfire.fhs" #-}
+saveGraph :: Graph -> FilePath -> IO ()
+{-# LINE 269 "Fenfire.fhs" #-}
+saveGraph graph fileName
+ = do uri <- liftM (fromJust . Network.URI.parseURI)
+ (Raptor.filenameToURI fileName)
+ let {-# LINE 273 "Fenfire.fhs" #-}
+ convert (s, p, o) = (f s, f p, f o)
+ {-# LINE 274 "Fenfire.fhs" #-}
+ f (URI s)
+ = Raptor.Uri $ fromMaybe s $
+ do u <- Network.URI.parseURI s
+ return $ show $ Network.URI.relativeFrom u uri
+ {-# LINE 277 "Fenfire.fhs" #-}
+ f (PlainLiteral s) = Raptor.Literal s
+ {-# LINE 278 "Fenfire.fhs" #-}
+ triples = graphToList graph
+ {-# LINE 279 "Fenfire.fhs" #-}
+ namespaces = Map.toAscList $ graphNamespaces graph
+ Raptor.triplesToFilename (map convert triples) namespaces fileName
+ putStrLn $ "Saved: " ++ fileName
+
+{-# LINE 283 "Fenfire.fhs" #-}
+newState :: Graph -> Path -> FilePath -> Bool -> FenState
+{-# LINE 284 "Fenfire.fhs" #-}
+newState graph path fp focus
+ = FenState graph path Set.empty fp False focus 0 rdfs_seeAlso ps []
+ []
+ where {-# LINE 286 "Fenfire.fhs" #-}
+ ps
+ = Set.insert rdfs_seeAlso $ Set.fromList $ map predicate $ filter f
+ $ graphToList graph
+ {-# LINE 288 "Fenfire.fhs" #-}
+ f (_, _, URI _) = True
+ {-# LINE 289 "Fenfire.fhs" #-}
+ f _ = False
+
+{-# LINE 291 "Fenfire.fhs" #-}
+stateReplaceNode :: Node -> Node -> Endo FenState
+{-# LINE 292 "Fenfire.fhs" #-}
+stateReplaceNode m n s@(FenState{fsPath = Path node cs})
+ = FenState{fsGraph = replaceNode m n (fsGraph s),
+ fsPath =
+ Path (f node) (map (\ (Conn p d n') -> Conn (f p) d (f n')) cs),
+ fsMark =
+ if m `Set.member` fsMark s then
+ Set.insert n $ Set.delete m $ fsMark s else fsMark s,
+ fsProperty = f (fsProperty s),
+ fsProperties = Set.map f (fsProperties s), fsGraphModified = True,
+ fsFilePath = fsFilePath s, fsHasFocus = fsHasFocus s,
+ fsView = fsView s, fsUndo = (fsGraph s, fsPath s) : fsUndo s,
+ fsRedo = []}
+ where {-# LINE 301 "Fenfire.fhs" #-}
+ f x = if x == m then n else x
diff -rN -u old-fenfire-hs/Main.hs new-fenfire-hs/Main.hs
--- old-fenfire-hs/Main.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenfire-hs/Main.hs 2007-02-28 17:52:11.000000000 +0200
@@ -0,0 +1,679 @@
+module Main 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 Utils
+import Cairo hiding (Path, rotate)
+import Vobs
+import qualified Raptor
+import RDF
+import VanishingView
+import Fenfire
+
+import Paths_fenfire (getDataFileName)
+
+import Control.Exception
+import Control.Monad
+import Control.Monad.State
+
+import Data.IORef
+import qualified Data.List
+import qualified Data.Set as Set
+
+import GtkFixes
+import Graphics.UI.Gtk hiding (Color, get, disconnect, fill,
+-- GtkFixes overrides:
+ actionNew,
+ widgetGetStyle,
+ styleGetForeground, styleGetBackground,
+ styleGetLight, styleGetMiddle, styleGetDark,
+ styleGetText, styleGetBase,
+ styleGetAntiAliasing)
+import Graphics.UI.Gtk.ModelView as New
+
+import qualified Network.URI
+
+import System.Directory (canonicalizePath)
+import System.Environment (getArgs, getProgName)
+
+openFile :: (?vs :: ViewSettings) => FilePath ->
+ IO (Maybe (Graph, FilePath))
+openFile 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 $ Just (graph, fileName)
+ _ -> return Nothing
+
+saveFile :: Graph -> FilePath -> Bool -> IO (FilePath,Bool)
+saveFile 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 ".turtle" s = s
+ | otherwise = s ++ ".turtle"
+
+confirmSave :: (?vs :: ViewSettings, ?pw :: Window,
+ ?views :: Views, ?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 ()
+
+confirmString :: (?vs :: ViewSettings, ?pw :: Window) =>
+ String -> String -> (String -> HandlerAction FenState) ->
+ HandlerAction FenState
+confirmString title preset action = do
+ (response,text) <- liftIO $ do
+ dialog <- makeDialog title
+ [(stockCancel, ResponseCancel),
+ (stockApply, ResponseAccept)]
+ ResponseAccept
+ entry <- entryNew
+ set entry [ entryText := preset, entryActivatesDefault := True ]
+ widgetShow entry
+ vBox <- dialogGetUpper dialog
+ boxPackStart vBox entry PackNatural 0
+ response' <- dialogRun dialog
+ text' <- entryGetText entry
+ widgetHide dialog
+ return (response',text')
+ case response of ResponseAccept -> action text
+ _ -> return ()
+handleEvent :: (?vs :: ViewSettings, ?pw :: Window, ?views :: Views,
+ ?uriMaker :: URIMaker) => Handler Event FenState
+handleEvent (Key { eventModifier=_mods, eventKeyName=key }) = do
+ state <- get; let graph = fsGraph 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"
+ "v" -> handleAction "chgview"
+ "p" -> handleAction "resetprop"
+ "O" -> handleAction "open"
+ "S" -> do (fp',saved) <- liftIO $ saveFile graph fileName False
+ let modified' = fsGraphModified state && not saved
+ put $ state { fsFilePath = fp', fsGraphModified = modified' }
+ _ -> unhandledEvent
+handleEvent _ = unhandledEvent
+
+handleAction :: (?vs :: ViewSettings, ?pw :: Window, ?views :: Views,
+ ?uriMaker :: URIMaker) => Handler String FenState
+handleAction action = do
+ state@(FenState { fsGraph = graph, fsPath = path, fsMark = mark,
+ fsFilePath = filepath, fsGraphModified = modified,
+ fsHasFocus=focus, fsProperty=prop
+ }) <- get
+ let ?graph = graph in do
+ let rot@(Rotation node _) = fsRotation state
+ b f x = maybeDo (f rot x) $ \rot' -> do
+ putRotation rot'
+ modify $ \s -> s { fsGraphModified = modified }
+ n f x = do (graph', rot') <- liftIO (f x prop (graph, rot))
+ putGraph graph'; putRotation rot'
+ o f x = do put (f x state); setInterp True
+ 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"-> o disconnect Neg ; "breakr"-> o disconnect Pos
+ "rmlit" -> putGraph (delLit node graph)
+ "mark" -> putMark $ toggleMark node mark
+ "new" -> confirmSave modified $ do
+ (g', path') <- liftIO newGraph
+ put $ newState g' path' "" focus
+ "open" -> confirmSave modified $ do
+ result <- liftIO $ openFile filepath
+ maybeDo result $ \(g',fp') -> do
+ uri <- liftM URI $ liftIO $ Raptor.filenameToURI fp'
+ let ts = containsInfoTriples uri g'
+ g'' = foldr insertVirtual g' ts
+ put $ newState g'' (findStartPath uri g'') fp' focus
+ "loadURI" -> case node of
+ URI uri -> do
+ g <- liftIO $ loadGraph uri
+ let ts = containsInfoTriples (URI uri) g
+ g' = foldr insertVirtual
+ (mergeGraphs graph g) ts
+ s' = state {fsGraph=g',
+ fsUndo=(graph,path):fsUndo state,
+ fsRedo=[]}
+ put s'
+ _ -> unhandledEvent
+ "revert" | filepath /= "" -> confirmRevert modified $ do
+ g' <- liftIO $ loadGraph filepath
+ gNode <- liftM URI $ liftIO $ Raptor.filenameToURI filepath
+ let g'' = foldr insertVirtual g' $ containsInfoTriples gNode g'
+ put $ newState g'' (findStartPath gNode g'') filepath focus
+ "save" | filepath /= "" -> do
+ liftIO $ saveGraph graph filepath
+ modify $ \s -> s { fsGraphModified = False }
+ | otherwise -> handleAction "saveas"
+ "saveas"-> do
+ (fp',saved) <- liftIO $ saveFile graph filepath True
+ let modified' = modified && not saved
+ modify $ \s -> s { fsFilePath = fp', fsGraphModified = modified' }
+ "quit" -> do confirmSave modified $ liftIO mainQuit
+ "about" -> liftIO $ makeAboutDialog >>= widgetShow
+ "chgview" -> do put $ state { fsView = (fsView state + 1) `mod`
+ (length ?views) }
+ setInterp True
+ "addprop" -> do let uri = case node of URI x -> x
+ _ -> ""
+ confirmString "Add property" uri $ \uri' ->
+ when (uri' /= "") $ do
+ let prop' = URI uri'
+ props = fsProperties state
+ put $ state { fsProperty = prop',
+ fsProperties = Set.insert prop' props }
+ "resetprop" -> when (fsProperty state /= rdfs_seeAlso) $
+ put $ state { fsProperty = rdfs_seeAlso }
+ "changeURI" -> case node of
+ URI uri -> confirmString "New URI" uri $ \uri' ->
+ put $ stateReplaceNode (URI uri) (URI uri') state
+ _ -> unhandledEvent
+ "undo" | (graph',path'):undos <- fsUndo state -> do
+ put state {fsGraph=graph', fsPath=path',
+ fsUndo=undos, fsRedo=(graph,path):fsRedo state}
+ setInterp True
+ "redo" | (graph',path'):redos <- fsRedo state -> do
+ put state {fsGraph=graph', fsPath=path',
+ fsUndo=(graph,path):fsUndo state, fsRedo=redos}
+ setInterp True
+ _ -> do liftIO $ putStrLn $ "Unhandled action: " ++ action
+ unhandledEvent
+ where putGraph g = do modify $ \s ->
+ s { fsGraph=g, fsGraphModified=True,
+ fsUndo=(fsGraph s, fsPath s):fsUndo s,
+ fsRedo=[]}
+ setInterp True
+ putRotation rot = do modify $ \s -> s { fsPath = toPath' rot }
+ setInterp True
+ putMark mk = do modify $ \state -> state { fsMark=mk }
+ delLit n graph = deleteAll n rdfs_label graph
+
+makeActions actionGroup accelGroup = do
+ let actionentries =
+ [ ( "new" , Nothing, stockNew , Nothing )
+ , ( "open" , Nothing, stockOpen , Nothing )
+ , ( "save" , Nothing, stockSave , Nothing )
+ , ( "saveas" , Nothing, stockSaveAs , Just "<Ctl><Shift>S" )
+ , ( "revert" , Nothing, stockRevertToSaved , Nothing )
+ , ( "quit" , Nothing, stockQuit , Nothing )
+ , ( "about" , Nothing, stockAbout , Nothing )
+ , ( "loadURI", Just "_Load node's URI",
+ stockGoForward , Just "<Ctl>L" )
+ , ( "undo" , Nothing, stockUndo , Just "<Ctl>Z" )
+ , ( "redo" , Nothing, stockRedo , Just "<Ctl><Shift>Z" )
+ ]
+ forM actionentries $ \(name,label',stock,accel) -> do
+ action <- actionNew name label' Nothing (Just stock)
+ actionGroupAddActionWithAccel actionGroup action accel
+ actionSetAccelGroup action accelGroup
+
+updateActions actionGroup stateRef = do
+ state <- readIORef stateRef
+ let readable = fsFilePath state /= ""
+ modified = fsGraphModified state
+ view = fst $ ?views !! (fsView state)
+
+ Just save <- actionGroupGetAction actionGroup "save"
+ actionSetSensitive save modified
+ Just revert <- actionGroupGetAction actionGroup "revert"
+ actionSetSensitive revert (modified && readable)
+ Just undo <- actionGroupGetAction actionGroup "undo"
+ actionSetSensitive undo (not $ null $ fsUndo state)
+ Just redo <- actionGroupGetAction actionGroup "redo"
+ actionSetSensitive redo (not $ null $ fsRedo state)
+ Just changeView <- actionGroupGetAction actionGroup view
+ toggleActionSetActive (castToToggleAction changeView) True
+
+updatePropMenu propmenu actionGroup stateRef updateCanvas = do
+ state <- readIORef stateRef
+ Just addProp <- actionGroupGetAction actionGroup "addprop"
+
+ menu <- menuNew
+ forM (Set.toAscList $ fsProperties state) $ \prop -> do
+ item <- let ?graph = fsGraph state
+ in menuItemNewWithLabel $ getTextOrURI prop
+ onActivateLeaf item $ do
+ modifyIORef stateRef $ \state' -> state' {fsProperty=prop}
+ updateCanvas False
+ menuShellAppend menu item
+ widgetShow item
+ sep <- separatorMenuItemNew
+ menuShellAppend menu sep
+ widgetShow sep
+ item <- actionCreateMenuItem addProp
+ menuShellAppend menu $ castToMenuItem item
+
+ menuItemSetSubmenu propmenu menu
+
+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" )
+ , ("addprop", Just "_Add property" ,
+ stockAdd , Just "<Ctl>P" )
+ , ("changeURI", Just "Change node's _URI" ,
+ stockRefresh , Just "u" )
+ ]
+ forM bindingentries $ \(name,label',stock,accel) -> do
+ action <- actionNew name label' Nothing (Just stock)
+ actionGroupAddActionWithAccel actionGroup action accel
+ actionSetAccelGroup action bindings
+
+makeMenus actionGroup root propmenu = addAll root menu where
+ menu = [m "_File" [a "new", a "open", a "loadURI", sep,
+ a "save", a "saveas", a "revert", sep,
+ a "quit"],
+ m "_Edit" [a "undo", a "redo", sep,
+ return propmenu, sep,
+ a "noder", a "nodel", sep,
+ a "breakr", a "breakl", sep,
+ a "mark", a "connr", a "connl", sep,
+ a "changeURI", a "rmlit"],
+ m "_View" (map (a . fst) ?views),
+ m "_Help" [a "about"]]
+ addAll parent items = mapM_ (menuShellAppend parent) =<< sequence items
+ m :: String -> [IO MenuItem] -> IO MenuItem
+ m name children = do item <- menuItemNewWithMnemonic name
+ menu' <- menuNew
+ addAll menu' children
+ menuItemSetSubmenu item menu'
+ return item
+ sep = liftM castToMenuItem separatorMenuItemNew
+ a name = do Just action <- actionGroupGetAction actionGroup name
+ item <- actionCreateMenuItem action
+ return (castToMenuItem item)
+
+makeToolbarItems actionGroup toolbar = do
+ forM_ ["new", "open", "save", "", "undo", "redo",""] $ \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
+
+ -- initial state:
+
+ args <- initGUI
+
+ window <- windowNew
+ style <- widgetGetStyle window
+
+ bgColor <- styleGetBackground style StateSelected
+ blurBgColor <- styleGetBackground style StateActive
+ focusColor <- styleGetBase style StateSelected
+ blurColor <- styleGetBase style StateActive
+ textColor <- styleGetText style StateSelected
+ blurTextColor <- styleGetText style StateActive
+
+ canvasBgColor <- styleGetBackground style StateNormal
+
+ let alpha x (Color r g b a) = Color r g b (x*a)
+
+ let ?vs = ViewSettings { hiddenProps=[rdfs_label], maxCenter=3 }
+ ?uriMaker = uriMaker in let
+ ?views = [("Wheel view", vanishingView 20 30
+ (alpha 0.7 $ fromGtkColor bgColor)
+ (alpha 0.7 $ fromGtkColor blurBgColor)
+ (fromGtkColor focusColor) (fromGtkColor blurColor)
+ (fromGtkColor textColor) (fromGtkColor blurTextColor)),
+ ("Presentation view", presentationView)] in do
+
+ let view s = snd (?views !! fsView s) s
+
+ stateRef <- case args of
+ [] -> do
+ (g, rot) <- newGraph
+ newIORef $ newState g rot "" False
+ xs -> do
+ let f x | Data.List.isPrefixOf "http:" x = return x
+ | otherwise = canonicalizePath x
+ fileName:fileNames <- mapM f xs
+ g' <- loadGraph fileName
+ gs <- mapM loadGraph fileNames
+ uri <- Raptor.filenameToURI fileName
+ uris <- mapM Raptor.filenameToURI fileNames
+ let ts = concatMap (uncurry containsInfoTriples) $
+ (URI uri, g') : zip (map URI uris) gs
+ graph = foldr insertVirtual (foldl mergeGraphs g' gs) ts
+ newIORef $ newState graph (findStartPath (URI uri) graph) fileName False
+
+ -- start:
+
+ makeWindow window canvasBgColor view stateRef
+ widgetShowAll window
+
+ mainGUI
+
+makeWindow window canvasBgColor view stateRef = do
+
+ -- main window:
+
+ let ?pw = window in mdo
+ logo <- getDataFileName "data/icon16.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 _ state@(FenState { fsPath=Path n _, fsGraph=g }) = do
+ buf <- textBufferNew Nothing
+ textBufferSetText buf (let ?graph=g in maybe "" id $ getText n)
+ afterBufferChanged buf $ do
+ start <- textBufferGetStartIter buf
+ end <- textBufferGetEndIter buf
+ text <- textBufferGetText buf start end True
+ s@(FenState { fsGraph = g' }) <- readIORef stateRef
+ let g'' = setText n text g' -- buf corresponds to n, not to n'
+
+ writeIORef stateRef $
+ s { fsGraph=g'', fsGraphModified=True, fsRedo=[],
+ fsUndo=(fsGraph s, fsPath s):(fsUndo s) }
+ updateActions actionGroup stateRef
+ updateCanvas True
+
+ textViewSetBuffer textView buf
+ updatePropMenu propmenu actionGroup stateRef updateCanvas
+ New.listStoreClear propList
+ forM_ (Set.toAscList $ fsProperties state) $ \prop ->
+ let ?graph = g in
+ New.listStoreAppend propList (prop, getTextOrURI prop)
+ let activeIndex = Data.List.elemIndex (fsProperty state)
+ (Set.toAscList $ fsProperties state)
+ maybe (return ()) (New.comboBoxSetActive combo) activeIndex
+
+ updateActions actionGroup stateRef
+
+ -- canvas for view:
+
+ (canvas, updateCanvas, canvasAction) <-
+ vobCanvas stateRef view handleEvent handleAction
+ stateChanged (fromGtkColor canvasBgColor) 0.5
+
+ onFocusIn canvas $ \_event -> do
+ modifyIORef stateRef $ \s -> s { fsHasFocus = True }
+ forM_ bindingActions $ actionConnectAccelerator
+ updateCanvas True
+ return True
+ onFocusOut canvas $ \_event -> do
+ modifyIORef stateRef $ \s -> s { fsHasFocus = False }
+ forM_ bindingActions $ actionDisconnectAccelerator
+ updateCanvas True
+ return True
+
+ -- action widgets:
+
+ accelGroup <- accelGroupNew
+ windowAddAccelGroup window accelGroup
+ -- bindings are active only when the canvas has the focus:
+ bindings <- accelGroupNew
+ windowAddAccelGroup window bindings
+ -- fake bindings aren't used
+ fake <- accelGroupNew
+
+ actionGroup <- actionGroupNew "main"
+ bindingGroup <- actionGroupNew "bindings"
+
+ makeActions actionGroup accelGroup
+ makeBindings bindingGroup bindings
+ makeBindings actionGroup fake
+
+ actions <- actionGroupListActions actionGroup
+ bindingActions <- actionGroupListActions bindingGroup
+
+ forM_ (actions ++ bindingActions) $ \action -> do
+ name <- actionGetName action
+ onActionActivate action $ canvasAction name >> return ()
+
+ viewActs <- forM (zip [0..] ?views) $ \(index, (name, _view)) -> do
+ action <- radioActionNew name name Nothing Nothing index
+ actionGroupAddAction actionGroup action
+ onActionActivate action $ do
+ i <- radioActionGetCurrentValue action
+ state <- readIORef stateRef
+ when (i /= fsView state) $ do
+ writeIORef stateRef $ state { fsView = i }
+ updateCanvas True
+ return action
+
+ forM_ (tail viewActs) $ \x -> radioActionSetGroup x (head viewActs)
+ toggleActionSetActive (toToggleAction $ head viewActs) True
+
+ -- user interface widgets:
+
+ menubar <- menuBarNew
+ propmenu <- menuItemNewWithMnemonic "Set _property"
+ makeMenus actionGroup menubar propmenu
+
+ toolbar <- toolbarNew
+ makeToolbarItems actionGroup toolbar
+
+ propList <- New.listStoreNew []
+ combo <- New.comboBoxNew
+ set combo [ New.comboBoxModel := Just propList
+ , New.comboBoxFocusOnClick := False ]
+ renderer <- New.cellRendererTextNew
+ New.cellLayoutPackStart combo renderer True
+ New.cellLayoutSetAttributes combo renderer propList $ \row ->
+ [ New.cellText := snd row ]
+ New.onChanged combo $ do
+ active <- New.comboBoxGetActive combo
+ case active of
+ Nothing -> return ()
+ Just i -> do
+ (prop,_name) <- listStoreGetValue propList i
+ state' <- readIORef stateRef
+ writeIORef stateRef $ state' {fsProperty=prop}
+ when (fsProperty state' /= prop) $ updateCanvas False
+
+ comboLabel <- labelNew (Just "Property: ")
+
+ comboVBox <- hBoxNew False 0
+ boxPackStart comboVBox comboLabel PackNatural 0
+ boxPackStart comboVBox combo PackNatural 0
+
+ comboAlign <- alignmentNew 0.5 0.5 1 0
+ containerAdd comboAlign comboVBox
+
+ combotool <- toolItemNew
+ containerAdd combotool comboAlign
+ toolbarInsert toolbar combotool (-1)
+
+ sepItem <- separatorToolItemNew
+ toolbarInsert toolbar sepItem (-1)
+
+ Just addpropAction <- actionGroupGetAction actionGroup "addprop"
+ addpropItem <- actionCreateToolItem addpropAction
+ toolbarInsert toolbar (castToToolItem addpropItem) (-1)
+
+ -- 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:
+
+ startState <- readIORef stateRef
+ stateChanged (startState { fsProperties = Set.empty }) startState
+
+ widgetGrabFocus canvas
+
+ onDelete window $ \_event -> canvasAction "quit"
+
+
+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
diff -rN -u old-fenfire-hs/Utils.hs new-fenfire-hs/Utils.hs
--- old-fenfire-hs/Utils.hs 2007-02-28 17:52:11.000000000 +0200
+++ new-fenfire-hs/Utils.hs 2007-02-28 17:52:11.000000000 +0200
@@ -84,12 +84,6 @@
for :: [a] -> (a -> b) -> [b]
for = flip map
-forM :: Monad m => [a] -> (a -> m b) -> m [b]
-forM = flip mapM
-
-forM_ :: Monad m => [a] -> (a -> m b) -> m ()
-forM_ = flip mapM_
-
forA2 :: Applicative f => f a -> f b -> (a -> b -> c) -> f c
forA2 x y f = liftA2 f x y
diff -rN -u old-fenfire-hs/fenfire.cabal new-fenfire-hs/fenfire.cabal
--- old-fenfire-hs/fenfire.cabal 2007-02-28 17:52:11.000000000 +0200
+++ new-fenfire-hs/fenfire.cabal 2007-02-28 17:52:11.000000000 +0200
@@ -16,11 +16,12 @@
Data-Files: data/logo.svg data/icon16.png
Executable: fenfire
-Main-Is: Fenfire.hs
-Other-Modules: Fenfire, Vobs, RDF, Cache, Cairo, Utils, Raptor, FunctorSugar, GtkFixes
+Main-Is: Main.hs
+Other-Modules: Fenfire, Vobs, RDF, Cache, Cairo, Utils, Raptor, FunctorSugar,
+ GtkFixes, VanishingView, Main
GHC-Options: -fglasgow-exts -hide-package haskell98 -Wall
-fno-warn-unused-imports -fno-warn-missing-signatures
- -fno-warn-orphans -fno-warn-deprecations -main-is Fenfire.main
+ -fno-warn-orphans -fno-warn-deprecations -main-is Main.main
Extra-Libraries: raptor
Executable: functortest
More information about the Fencommits
mailing list