Fri Oct 7 11:23:45 WEST 2005 Malcolm.Wallace@cs.york.ac.uk
* big one
Lots of overlapping things here.
* class Read is no longer a superclass of Parse
* add more parameterised InfoKind types to various Network types
- global info (mainly for checking against node info) on Network
- edge info on Edge
* GUI options to show/edit the new info
- removed boxes around GUI labels, and moved labels closer to their blobs.
- info on Edges now shown
* class InfoKind becomes multi-parameter, linking two info types
(e.g. node with global, edge with global)
* new multi-parameter class Analysis, whose member method essentially
takes a whole network and returns a new one.
FPTC is now a specific instance of the general GUI + class Analysis.
* data FaultModel records global info: failure types of interest.
* the original FPTC analysis from the previous tool has been plumbed in.
{
hunk ./Makefile 25
- src/DisplayOptions.hs \
+ src/DisplayOptions.hs src/Analysis.hs \
hunk ./Makefile 27
- src/FPTC/ListStuff.hs \
+ src/FPTC/ListStuff.hs src/FPTC/PointTrace.hs \
+ src/FPTC/Analysis.hs \
hunk ./Makefile 94
+src/Main.o : lib/DData/Set.hi
+src/Main.o : src/FPTC/Analysis.hi
+src/Main.o : src/FPTC/FaultSpec.hi
hunk ./Makefile 113
+src/GUIEvents.o : src/Parse.hi
hunk ./Makefile 153
+src/Document.o : src/InfoKind.hi
hunk ./Makefile 156
+src/NetworkUI.o : src/NetworkControl.hi
+src/NetworkUI.o : src/Analysis.hi
+src/NetworkUI.o : src/Parse.hi
hunk ./Makefile 202
+src/ContextMenu.o : src/Parse.hi
hunk ./Makefile 228
+src/Analysis.o : src/Analysis.hs
+src/Analysis.o : lib/DData/IntMap.hi
+src/Analysis.o : src/PersistentDocument.hi
+src/Analysis.o : src/Document.hi
+src/Analysis.o : src/State.hi
+src/Analysis.o : src/Node.hi
+src/Analysis.o : src/Network.hi
+src/Analysis.o : src/InfoKind.hi
hunk ./Makefile 237
+src/FPTC/Expressions.o : lib/DData/Set.hi
hunk ./Makefile 241
+src/FPTC/Expressions.o : src/Parse.hi
hunk ./Makefile 245
-src/FPTC/FaultSpec.o : src/InfoKind.hi
+src/FPTC/FaultSpec.o : src/Parse.hi
hunk ./Makefile 247
+src/FPTC/PointTrace.o : src/FPTC/PointTrace.hs
+src/FPTC/PointTrace.o : lib/DData/Set.hi
+src/FPTC/PointTrace.o : src/FPTC/FaultSpec.hi
+src/FPTC/PointTrace.o : src/FPTC/Expressions.hi
+src/FPTC/Analysis.o : src/FPTC/Analysis.hs
+src/FPTC/Analysis.o : src/Node.hi
+src/FPTC/Analysis.o : src/Network.hi
+src/FPTC/Analysis.o : lib/DData/IntMap.hi
+src/FPTC/Analysis.o : lib/DData/Set.hi
+src/FPTC/Analysis.o : src/Analysis.hi
+src/FPTC/Analysis.o : src/InfoKind.hi
+src/FPTC/Analysis.o : src/FPTC/ListStuff.hi
+src/FPTC/Analysis.o : src/FPTC/PointTrace.hi
+src/FPTC/Analysis.o : src/FPTC/FaultSpec.hi
+src/FPTC/Analysis.o : src/FPTC/Expressions.hi
addfile ./src/Analysis.hs
hunk ./src/Analysis.hs 1
+module Analysis where
+
+import InfoKind
+import Network
+import Node
+import State
+import Document
+import qualified PersistentDocument as PD
+
+import IntMap
+
+-- | An @Analysis@ class links two InfoKind types together (one for nodes,
+-- one for edges). A blobs graph is passed in and a fresh one received
+-- back again. Currently, the analysis method can choose to update
+-- any of the info labels on nodes or edges, or indeed the edge/node
+-- connection topology (by adding/deleting edges or nodes).
+class (InfoKind n g, InfoKind e g) => Analysis g n e where
+ -- n = node info type
+ -- e = edge info type
+ -- g = global info type
+ analyse :: (g, IntMap (Node n), IntMap (Edge e)) ->
+ (g, IntMap (Node n), IntMap (Edge e))
+
+callAnalysis :: Analysis g n e => State g n e -> IO ()
+callAnalysis state = [_$_]
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; let network = getNetwork doc
+ g = getGlobalInfo network
+ n = networkNodes network
+ e = networkEdges network
+ (g',n',e') = analyse (g,n,e)
+ network' = setNodeAssocs (assocs n')
+ $ setEdgeAssocs (assocs e')
+ $ setGlobalInfo g'
+ $ network
+ ; PD.updateDocument "perform analysis" (setNetwork network') pDoc
+ }
hunk ./src/ContextMenu.hs 15
+import Parse
hunk ./src/ContextMenu.hs 21
-canvas :: InfoKind a => Frame () -> State a -> IO ()
+canvas :: (InfoKind n g, Show g, Parse g) => Frame () -> State g n e -> IO ()
hunk ./src/ContextMenu.hs 28
+ ; menuItem contextMenu
+ [ text := "Edit global info"
+ , on command := safetyNet theFrame $ changeGlobalInfo theFrame state
+ ]
hunk ./src/ContextMenu.hs 38
-addNodeItem :: InfoKind a => Frame () -> State a -> IO ()
+addNodeItem :: (InfoKind n g) => Frame () -> State g n e -> IO ()
hunk ./src/ContextMenu.hs 47
-edge :: Frame () -> DoublePoint -> State a -> IO ()
+edge :: Frame () -> DoublePoint -> State g n e -> IO ()
hunk ./src/ContextMenu.hs 64
-via :: Frame () -> State a -> IO ()
+via :: Frame () -> State g n e -> IO ()
hunk ./src/ContextMenu.hs 77
-node :: InfoKind a => Int -> Frame () -> State a -> IO ()
+node :: (InfoKind n g) => Int -> Frame () -> State g n e -> IO ()
hunk ./src/DisplayOptions.hs 3
-data ShowInfo = Label | Info | LabelAndInfo
- deriving (Eq)
+import List ((\\))
+
+type ShowInfo = [What]
+data What = NodeLabel | NodeInfo | EdgeInfo deriving (Eq)
hunk ./src/DisplayOptions.hs 13
-standard = DP Label
+standard = DP [NodeLabel]
+
+toggle :: What -> DisplayOptions -> DisplayOptions
+toggle w (DP opts) = DP (if w `elem` opts then opts\\[w] else w:opts)
hunk ./src/Document.hs 19
+import InfoKind
hunk ./src/Document.hs 25
-data Document a = Document
- { docNetwork :: Network.Network a
+data Document g n e = Document
+ { docNetwork :: Network.Network g n e
hunk ./src/Document.hs 43
-empty :: Document a
-empty =
+empty :: (InfoKind e g, InfoKind n g) => g -> n -> e -> Document g n e
+empty g n e =
hunk ./src/Document.hs 46
- { docNetwork = Network.empty
+ { docNetwork = Network.empty g n e
hunk ./src/Document.hs 54
-getNetwork :: Document a -> Network.Network a
-getSelection :: Document a -> Selection
+getNetwork :: Document g n e -> Network.Network g n e
+getSelection :: Document g n e -> Selection
hunk ./src/Document.hs 66
-setNetwork :: Network.Network a -> Document a -> Document a
+setNetwork :: Network.Network g n e -> Document g n e -> Document g n e
hunk ./src/Document.hs 72
-setSelection :: Selection -> Document a -> Document a
+setSelection :: Selection -> Document g n e -> Document g n e
hunk ./src/Document.hs 75
-updateNetwork :: (Network.Network a -> Network.Network a)
- -> Document a -> Document a
+updateNetwork :: (Network.Network g n e -> Network.Network g n e)
+ -> Document g n e -> Document g n e
hunk ./src/Document.hs 81
-updateNetworkEx :: (Network.Network a -> (b, Network.Network a))
- -> Document a -> (b, Document a)
+updateNetworkEx :: (Network.Network g n e -> (b, Network.Network g n e))
+ -> Document g n e -> (b, Document g n e)
hunk ./src/Document.hs 90
-unsafeSetNetwork :: Network.Network a -> Document a -> Document a
+unsafeSetNetwork :: Network.Network g n e -> Document g n e -> Document g n e
addfile ./src/FPTC/Analysis.hs
hunk ./src/FPTC/Analysis.hs 1
+module FPTC.Analysis where
+
+import FPTC.Expressions
+import FPTC.FaultSpec
+import FPTC.PointTrace as PointTrace
+import FPTC.ListStuff (permute,transpose)
+import InfoKind
+import Analysis
+import Set (Set)
+import qualified Set as Set
+import Data.FiniteMap
+import IntMap (IntMap)
+import qualified IntMap
+import Network
+import Node
+import Maybe (fromJust)
+
+-- FPTC analysis takes a FaultTransform on each node, and produces
+-- a Set Fault on each edge.
+instance Analysis FaultModel FaultTransform (Set Fault) where
+ analyse (g, nodemap, edgemap) = (g, nodemap, edgemap')
+ where edgemap' = stabilise nodemap (IntMap.map (\e->e{edgeInfo=()}) edgemap)
+
+------------------------------------------------------------------------
+
+-- | The outcome of the analysis associates a faultset to each connection.
+-- The Int keys here are identical to those in the original IntMap (Edge e).
+type Outcome = IntMap (Set (Fault,PointTrace))
+
+-- | A simplified representation of nodes - we are only interested in
+-- their connections, and their FTPC clauses.
+data SimpleNode = SimpleNode
+ { transforms :: [FaultClause]
+ , inbound :: [EdgeNr] -- ordered by incoming port number ?
+ , outbound :: [EdgeNr] -- ordered by outgoing port number ?
+ }
+type SimpleGraph = IntMap SimpleNode -- keys are identical to IntMap (Node n)
+
+------------------------------------------------------------------------
+
+-- | Do the FPTC propagation and transformation until a stable point is reached.
+stabilise :: IntMap (Node FaultTransform) -> IntMap (Edge ())
+ -> IntMap (Edge (Set Fault))
+stabilise ns es =
+ let (init, graph) = initialise True es ns
+ outcome = fixpoint (calculateOutwardFaults True graph)
+ eqFaultSets init
+ in IntMap.mapWithKey -- drop PointTraces silently here
+ (\k e-> e { edgeInfo = maybe errorSet (Set.map fst)
+ (IntMap.lookup k outcome) } )
+ es
+ where
+ errorSet = Set.singleton (Fault "***mistake_in_algorithm***")
+
+-- | Calculate a function's fixpoint by repeated application until two
+-- successive values are equal.
+fixpoint :: (a->a) -> (a->a->Bool) -> a -> a
+fixpoint f eq x | fx `eq` x = x
+ | otherwise = fixpoint f eq fx
+ where fx = f x
+
+-- | Compare two network's FaultSets, component by component, to determine
+-- equality (and hence the termination of the fixpoint algorithm).
+-- Assumes that the finitemaps have identical key sets (and orderings).
+--eqFaultSets :: Eq a => Outcome a -> Outcome a -> Bool
+--eqFaultSets fm1 fm2 = foldr1 (&&) (zipWith (==) (eltsFM fm1) (eltsFM fm2))
+-- ^^^^^ Note that we really do mean (==) here, not `eqF`, because we need
+-- to compare the auxiliary info as well as the faults themselves.
+eqFaultSets :: Outcome -> Outcome -> Bool
+eqFaultSets = (==)
+
+-- | Grab a first-approximation to the faultset for each connection,
+-- and a simplified version of the graph.
+initialise :: Bool -> IntMap (Edge ()) -> IntMap (Node FaultTransform)
+ -> (Outcome, SimpleGraph)
+initialise closed edges nodes =
+ ( IntMap.map (const (if closed then Set.singleton (Normal,noInfo)
+ else Set.empty))
+ edges
+ , IntMap.mapWithKey simple nodes
+ )
+ where
+ simple key node =
+ SimpleNode
+ { transforms = tsort (clauses (getInfo node))
+ , inbound = IntMap.keys $ IntMap.filter ((==key) . edgeTo) edges
+ , outbound = IntMap.keys $ IntMap.filter ((==key) . edgeFrom) edges
+ }
+ -- Topological sort of transforms, by partial ordering on pattern
+ -- generality, most specific pattern first.
+ tsort [] = [] -- no implicit default clause
+ tsort cs = foldr tinsert [] cs
+ where tinsert x [] = [x]
+ tinsert x (y:ys) = case poTuple (lhs x) (lhs y) of
+ LessThan -> y: tinsert x ys
+ _ -> x: y: ys
+
+------------------------------------------------------------------------
+
+-- | Calculate an individual component's outbound faults from its inbound
+-- faults, using the transform for that component.
+calculateOutwardFaults :: Bool -> SimpleGraph -> Outcome -> Outcome
+calculateOutwardFaults closed graph before =
+ IntMap.fold (\n outcome->
+ foldr (\ (edgeNr,fs) z->
+ IntMap.insertWith joinOutcomes edgeNr fs z)
+ outcome
+ (zip (outbound n) (apply (transforms n) (infaults n))))
+ before
+ graph
+ where
+ infaults c = case inbound c of
+ [] -> if closed then [Set.singleton Normal] else []
+ cs -> map (Set.map fst . fromJust
+ . flip (IntMap.lookup) before) cs
+
+-- | Apply the fault transform expression to the actual inbound faultsets,
+-- to generate the outbound faultsets. The inbound faults are permuted,
+-- to give all possible combinations. On each combination, the first rule
+-- to match is triggered. (Rules are ordered by most-specific to
+-- most-general.) If no rule matches, the expression is in error.
+
+apply :: [FaultClause] -> [Set Fault] -> [Set (Fault,PointTrace)]
+apply rules =
+ map amalgamate
+ . transpose
+ . map ((rules `app`) . map A)
+ . permute
+ . map Set.elems
+ where
+ -- infaults: is a sequence 1..n of faultsets, one set per input port.
+ -- permuted infaults: is an unordered list of sequences 1..n, each element
+ -- of the sequence being a single fault, one per input port.
+ -- Every permuted input *must* find a matching rule, since there are no
+ -- automatic defaults. Not every rule needs to fire, if no input matches.
+
+ app :: [FaultClause] -> [FaultSpec] -> [Set (Fault,PointTrace)]
+ [] `app` f = error ("no matching rule for fault permutation "
+ ++ show f ++" in rules\n "++ show rules)
+ (rule:rules) `app` f | rule `matches` f = rule `bind` (map deA f)
+ | otherwise = rules `app` f
+
+ -- does a clause match the pattern?
+ matches :: FaultClause -> [FaultSpec] -> Bool
+ rule `matches` input = foldr (&&) True (zipWith match (lhs rule) input)
+
+ -- given that a clause matches, return the RHS with variables bound
+ -- by substitution, and a point trace attached to everything.
+ bind :: FaultClause -> [Fault] -> [Set (Fault,PointTrace)]
+ rule `bind` input = map ( attach (mkTrace rule input)
+ . chain (zipWith mkEnv (lhs rule) input))
+ (rhs rule)
+ where
+ -- 'mkEnv' creates a point environment mapping vars to faults
+ -- first arg is LHS particle, second is actual propagated fault,
+ -- third is RHS potential use of variable,
+ -- result is resolved RHS use.
+ mkEnv :: FaultSpec -> Fault -> FaultSpec -> FaultSpec
+ mkEnv (A (Var v)) f (A (Var w)) | w==v [_$_]
+ = A f
+ mkEnv v f (Or s) = Or (Set.map (deA . mkEnv v f . A) s)
+ mkEnv _ _ f = f
+
+ -- 'chain' together a bunch of functions
+ chain :: [a->a] -> a -> a
+ chain fs = foldr (.) id fs
+
+ attach :: PointTrace -> FaultSpec -> Set (Fault,PointTrace)
+ attach t (A Normal) = Set.singleton (Normal, noInfo)
+ attach t (A f) = Set.singleton (f,t)
+ attach t (Or s) = Set.map (\f-> case f of
+ Normal -> (Normal,noInfo)
+ _ -> (f,t))
+ s
+ attach t f = error ("Could not resolve RHS term "++show f
+ ++" when applying: \n "++show rule
+ ++"\n to input: "++show input)
+
+------------------------------------------------------------------------
+-- join singleton faults and sets produced as output of 'bind',
+-- and amalgamate all PointTraces for any particular fault
+amalgamate :: [Set (Fault,PointTrace)] -> Set (Fault,PointTrace)
+amalgamate ss =
+ let x :: FiniteMap Fault PointTrace
+ x = foldr (\s acc-> Set.fold (\ (f,t) fm->
+ addToFM_C PointTrace.plus fm f t)
+ acc s)
+ emptyFM ss
+ in Set.fromList (fmToList x)
+
+-- pairwise join of faultsets
+joinOutcomes :: Set (Fault,PointTrace) -> Set (Fault,PointTrace)
+ -> Set (Fault,PointTrace)
+joinOutcomes s1 s2 = amalgamate [s1,s2]
+
+{-
+amalgamate :: [Set Fault] -> Set Fault
+amalgamate = foldr Set.union Set.empty
+
+joinOutcomes :: Set Fault -> Set Fault -> SetFault
+joinOutcomes = Set.union
+-}
+------------------------------------------------------------------------
hunk ./src/FPTC/Expressions.hs 5
-import FPTC.ListStuff (commasep,readSequence,mapFst,permute,indent)
+import FPTC.ListStuff (commasep,readSequence,mapFst,permute,indent,intersperse)
hunk ./src/FPTC/Expressions.hs 9
+import Set (Set)
+import qualified Set as Set
hunk ./src/FPTC/Expressions.hs 13
+data FaultModel = FaultModel [String] deriving (Eq)
hunk ./src/FPTC/Expressions.hs 15
- { clauses :: [FaultClause] } deriving (Eq)
-data FaultClause = Pattern :->: Pattern deriving (Eq,Ord)
-type Pattern = [FaultSpec]
+ { clauses :: [FaultClause] } deriving (Eq)
+data FaultClause = Pattern :->: Pattern deriving (Eq,Ord)
+type Pattern = [FaultSpec]
hunk ./src/FPTC/Expressions.hs 26
+instance Show FaultModel where
+ show (FaultModel fs) = "FaultModel ["++concat (intersperse "," fs) ++"]"
hunk ./src/FPTC/Expressions.hs 33
+
hunk ./src/FPTC/Expressions.hs 48
+
+instance Parse String where
+ parse = word
+instance Parse FaultModel where
+ parse = fmap FaultModel $ do
+ { isWord "FaultModel"
+ ; bracketSep (isWord "[") (isWord ",") (isWord "]") parse
+ }
hunk ./src/FPTC/Expressions.hs 88
-instance InfoKind FaultTransform where
+instance InfoKind FaultTransform FaultModel where
hunk ./src/FPTC/Expressions.hs 90
- check nm fptc = fptcExhaustive nm ["Timing","Value"] fptc
+ check nm faultnames fptc =
+ allFaultsValid nm faultnames fptc
+ ++ allClausesSameArity nm faultnames fptc
+ ++ fptcExhaustive nm faultnames fptc
+ -- ++ fptcNoOverlaps
+ -- ++ fptcNoDuplicateLhsVariables
+ -- ++ fptcAllLhsVariablesUsed
+ -- ++ fptcAllLhsSetsKosher
+ -- ++ fptcAllRhsVariablesBound
+instance InfoKind (Set Fault) FaultModel where
+ blank = Set.empty
+ check nm (FaultModel fs) set =
+ let rogues = filter (`notElem` (map Fault fs)) (Set.toList set)
+ in if not (null rogues) then ["These faults found on edge "++nm
+ ++" are invalid:\n\t"++show rogues]
+ else []
hunk ./src/FPTC/Expressions.hs 122
+instance Haskell2XmlNew FaultModel where
+ toHType _ = Defined "FaultModel" [] []
+ toContents (FaultModel fs) =
+ [ CElem (Elem "FaultModel" [] (concatMap toContents fs)) () ]
+ parseContents = do
+ { fs <- element' ["FaultModel"] $ nonemptylist parseContents
+ ; return (FaultModel fs)
+ }
hunk ./src/FPTC/Expressions.hs 131
-fptcExhaustive :: String -> [String] -> FaultTransform -> [String]
-fptcExhaustive nm faults fptc =
+fptcExhaustive :: String -> FaultModel -> FaultTransform -> [String]
+fptcExhaustive nm (FaultModel faultnames) fptc =
hunk ./src/FPTC/Expressions.hs 145
- allFaults = A Normal: map (A . Fault) faults
+ allFaults = A Normal: map (A . Fault) faultnames
hunk ./src/FPTC/Expressions.hs 148
+allFaultsValid :: String -> FaultModel -> FaultTransform -> [String]
+allFaultsValid nm (FaultModel faultnames) fptc =
+ check nm (clauses fptc)
+ where
+ check n cls = let fs = actuals (concat (map lhs cls ++ map rhs cls))
+ in case filter (`notElem` faultnames) fs of
+ [] -> []
+ es -> ["FPTC for node \""++n ++"\" mentions unknown\
+ \ fault(s):\n "++show es]
+ actuals fs = [ f | A (Fault f) <- fs ] ++
+ [ f | Or s <- fs, Fault f <- Set.elems s ]
+
+allClausesSameArity :: String -> FaultModel -> FaultTransform -> [String]
+allClausesSameArity n _ fptc =
+ let rules = clauses fptc
+ lhss = map (length.lhs) rules
+ rhss = map (length.rhs) rules
+ in if any (< maximum lhss) lhss
+ then ["FPTC for node \""++n++"\" has differing LHS arities: "++show lhss]
+ else []
+ ++
+ if any (< maximum rhss) rhss
+ then ["FPTC for node \""++n++"\" has differing RHS arities: "++show rhss]
+ else []
hunk ./src/FPTC/FaultSpec.hs 65
-instance Read (Set a)
+--instance Read (Set a)
addfile ./src/FPTC/PointTrace.hs
hunk ./src/FPTC/PointTrace.hs 1
+{- A pointwise-trace type, and its operations.
+-}
+module FPTC.PointTrace where
+
+import FPTC.Expressions
+import FPTC.FaultSpec
+import Set (Set)
+import qualified Set as Set
+
+-- | A PointTrace is a collection of clause/pattern pairs whose invocation
+-- caused a fault token to be attached to an arc. Note the caused fault
+-- is not stored here - the association is represented elsewhere.
+data PointTrace = Trace (Set (FaultClause,[Fault]))
+ deriving (Eq,Ord)
+instance Show PointTrace where
+ show (Trace cps) = let (clauses,patterns) = unzip (Set.elems cps)
+ in '\n':unlines (zipWith table clauses patterns)
+ where table cl pat = "\t"++show pat++"\tmatched by "++show cl
+
+
+-- Some info-theoretic operations on traces:
+
+-- | 'noInfo': the algebraic zero of the information type
+noInfo :: PointTrace
+noInfo = Trace Set.empty
+
+-- | combine information generated by different rules firing based on
+-- different inputs.
+plus :: PointTrace -> PointTrace -> PointTrace
+plus (Trace t1) (Trace t2) = Trace (t1 `Set.union` t2)
+
+-- | create a pointtrace
+mkTrace :: FaultClause -> [Fault] -> PointTrace
+mkTrace rule pat = Trace (Set.singleton (rule,pat))
+
+
+{-
+-- Lift trace operations into useful functions over FaultSpecs:
+
+empty :: [(FaultSpec,PointTrace)]
+empty = []
+--empty = Set [Star noInfo] -- normal behaviour is always possible!
+
+combine :: Info a => [FaultSpec a] -> FaultSpec a
+combine fs = Set (foldr join [] fs)
+ where join item [] = [item]
+ join f (f':faults)
+ | f `eqF` f' = f { info = info f `plus` info f' } : faults
+ | otherwise = f' : join f faults
+-}
hunk ./src/GUIEvents.hs 12
+import Parse
hunk ./src/GUIEvents.hs 17
-mouseDown :: InfoKind a => Bool -> Point -> Frame () -> State a -> IO ()
+mouseDown :: (InfoKind n g, Show g, Parse g) =>
+ Bool -> Point -> Frame () -> State g n e -> IO ()
hunk ./src/GUIEvents.hs 56
-leftMouseDownWithShift :: InfoKind a => Point -> State a -> IO ()
+leftMouseDownWithShift :: (InfoKind n g, InfoKind e g) =>
+ Point -> State g n e -> IO ()
hunk ./src/GUIEvents.hs 78
-leftMouseDrag :: Point -> ScrolledWindow () -> State a -> IO ()
+leftMouseDrag :: Point -> ScrolledWindow () -> State g n e -> IO ()
hunk ./src/GUIEvents.hs 95
-leftMouseUp :: Point -> State a -> IO ()
+leftMouseUp :: Point -> State g n e -> IO ()
hunk ./src/GUIEvents.hs 112
-deleteKey :: State a -> IO ()
+deleteKey :: State g n e -> IO ()
hunk ./src/GUIEvents.hs 116
-backspaceKey :: State a -> IO ()
+backspaceKey :: State g n e -> IO ()
hunk ./src/GUIEvents.hs 120
-f2Key :: Frame () -> State a -> IO () -- due for demolition
+f2Key :: Frame () -> State g n e -> IO () -- due for demolition
hunk ./src/GUIEvents.hs 124
-pressRKey :: Frame () -> State a -> IO ()
+pressRKey :: Frame () -> State g n e -> IO ()
hunk ./src/GUIEvents.hs 128
-pressIKey :: InfoKind a => Frame () -> State a -> IO ()
+pressIKey :: (InfoKind n g) => Frame () -> State g n e -> IO ()
hunk ./src/GUIEvents.hs 132
-upKey :: State a -> IO ()
+upKey :: State g n e -> IO ()
hunk ./src/GUIEvents.hs 136
-downKey :: State a -> IO ()
+downKey :: State g n e -> IO ()
hunk ./src/InfoKind.hs 5
+import Data.FiniteMap
hunk ./src/InfoKind.hs 11
+-- against some global type.
hunk ./src/InfoKind.hs 13
-class (Eq a, Show a, Parse a, Haskell2XmlNew a) => InfoKind a where
+class (Eq a, Show a, Parse a, Haskell2XmlNew a) => InfoKind a g | a -> g where
hunk ./src/InfoKind.hs 15
- check :: String -> a -> [String] -- returns warnings
- -- ^ first arg is label of blob, for error reporting
+ check :: String -> g -> a -> [String] -- returns warnings
+ -- ^ first arg is container label for error reporting.
+ -- second arg is global value
hunk ./src/InfoKind.hs 20
-instance InfoKind () where
+instance InfoKind () () where
hunk ./src/InfoKind.hs 22
- check _ () = []
+ check _ _ () = []
hunk ./src/InfoKind.hs 24
-instance InfoKind a => InfoKind (Maybe a) where
+instance InfoKind a b => InfoKind (Maybe a) b where
hunk ./src/InfoKind.hs 26
- check n Nothing = ["No info value stored with "++n]
- check n (Just a) = check n a
+ check n _ Nothing = ["No info value stored with "++n]
+ check n g (Just a) = check n g a
hunk ./src/InfoKind.hs 29
-
-{-
-class (Eq a, Parse a, Show a, Haskell2XmlNew a) => InfoKind a g where
- -- g is global datatype possibly related to a.
- blank :: a
- check :: String -> g -> a -> [String]
- -- in the case of a==FaultTransform, g==[String] meaning all faults.
- -- no parse or splat, use Parse and Show instances instead.
-
-class (Eq c, Parse c, Show c, Haskell2XmlNew c
- , Eq g, Parse g, Show g, Haskell2XmlNew g,
- , Eq e, Parse e, Show e, Haskell2XmlNew e) => InfoKind c g e where
--- c = component info type
--- g = global info type
--- e = edge info type
--}
hunk ./src/Main.hs 8
-import FPTC.Expressions
+import FPTC.Expressions (FaultModel(..),FaultTransform)
+import FPTC.FaultSpec (Fault)
+import FPTC.Analysis
+import Set (Set,empty)
hunk ./src/Main.hs 16
- ; NetworkUI.create state (undefined::FaultTransform)
- -- 2nd arg used only to monomorphise InfoKind field of State.
+ ; NetworkUI.create state (FaultModel [])
+ (undefined::FaultTransform)
+ (Set.empty::Set Fault)
+ -- trailing args used only to monomorphise InfoKind field of State.
hunk ./src/Network.hs 6
- , networkEdges
+ , networkNodes -- dangerous
+ , networkEdges -- dangerous
hunk ./src/Network.hs 17
+ , getGlobalInfo, setGlobalInfo
hunk ./src/Network.hs 48
-data Network a = Network
- { networkNodes :: !(IntMap (Node.Node a)) -- ^ maps node numbers to nodes
- , networkEdges :: !(IntMap Edge) -- ^ maps edge numbers to edges
+data Network g n e = Network
+ { networkNodes :: !(IntMap (Node.Node n)) -- ^ maps node numbers to nodes
+ , networkEdges :: !(IntMap (Edge e)) -- ^ maps edge numbers to edges
hunk ./src/Network.hs 52
+ , networkInfo :: g
hunk ./src/Network.hs 55
-data Edge = Edge
+data Edge e = Edge
hunk ./src/Network.hs 59
+ , edgeInfo :: e
hunk ./src/Network.hs 67
-empty :: Network a
-empty = Network
+empty :: (InfoKind n g, InfoKind e g) => g -> n -> e -> Network g n e
+empty g _ _ = Network
hunk ./src/Network.hs 72
+ , networkInfo = g
hunk ./src/Network.hs 78
-mapNodeNetwork :: (Node.Node a -> Node.Node b) -> Network a -> Network b
+mapNodeNetwork :: (Node.Node n->Node.Node m) -> Network g n e -> Network g m e
hunk ./src/Network.hs 86
+ , networkInfo = networkInfo network
hunk ./src/Network.hs 90
-getUnusedNodeNr :: Network a -> NodeNr
+getUnusedNodeNr :: Network g n e -> NodeNr
hunk ./src/Network.hs 97
-getUnusedEdgeNr :: Network a -> EdgeNr
+getUnusedEdgeNr :: Network g n e -> EdgeNr
hunk ./src/Network.hs 104
-getParents :: Network a -> NodeNr -> [NodeNr]
+getParents :: Network g n e -> NodeNr -> [NodeNr]
hunk ./src/Network.hs 116
-getParentMap :: Network a -> ParentMap
+getParentMap :: Network g n e -> ParentMap
hunk ./src/Network.hs 124
-getChildren :: Network a -> NodeNr -> [NodeNr]
+getChildren :: Network g n e -> NodeNr -> [NodeNr]
hunk ./src/Network.hs 134
-getNode :: NodeNr -> Network a -> Node.Node a
+getNode :: NodeNr -> Network g n e -> Node.Node n
hunk ./src/Network.hs 142
-getEdge :: EdgeNr -> Network a -> Edge
+getEdge :: EdgeNr -> Network g n e -> Edge e
hunk ./src/Network.hs 146
-getNodes :: Network a -> [Node.Node a]
+getNodes :: Network g n e -> [Node.Node n]
hunk ./src/Network.hs 150
-getEdges :: Network a -> [Edge]
+getEdges :: Network g n e -> [Edge e]
hunk ./src/Network.hs 154
-getNodeNrs :: Network a -> [NodeNr]
+getNodeNrs :: Network g n e -> [NodeNr]
hunk ./src/Network.hs 157
-getCanvasSize :: Network a -> (Double, Double)
+getCanvasSize :: Network g n e -> (Double, Double)
hunk ./src/Network.hs 160
+getGlobalInfo :: Network g n e -> g
+getGlobalInfo network = networkInfo network
+
hunk ./src/Network.hs 164
-findEdge :: NodeNr -> NodeNr -> Network a -> Maybe EdgeNr
+findEdge :: NodeNr -> NodeNr -> Network g n e -> Maybe EdgeNr
hunk ./src/Network.hs 167
- (sameFromAndTo (Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr, edgeVia = [] }))
+ (sameFromAndTo (Edge { edgeFrom = fromNodeNr
+ , edgeTo = toNodeNr
+ , edgeVia = undefined
+ , edgeInfo = undefined }))
hunk ./src/Network.hs 177
-findNodeNrsByName :: String -> Network a -> [NodeNr]
+findNodeNrsByName :: String -> Network g n e -> [NodeNr]
hunk ./src/Network.hs 186
-getNodeAssocs :: Network a -> [(NodeNr, Node.Node a)]
+getNodeAssocs :: Network g n e -> [(NodeNr, Node.Node n)]
hunk ./src/Network.hs 189
-setNodeAssocs :: [(NodeNr, Node.Node a)] -> Network a -> Network a
+setNodeAssocs :: [(NodeNr, Node.Node n)] -> Network g n e -> Network g n e
hunk ./src/Network.hs 194
-getEdgeAssocs :: Network a -> [(EdgeNr, Edge)]
+getEdgeAssocs :: Network g n e -> [(EdgeNr, Edge e)]
hunk ./src/Network.hs 197
-setEdgeAssocs :: [(EdgeNr, Edge)] -> Network a -> Network a
+setEdgeAssocs :: [(EdgeNr, Edge e)] -> Network g n e -> Network g n e
hunk ./src/Network.hs 202
-dumpNetwork :: Network String -> String
+dumpNetwork :: InfoKind e g => Network g String e -> String
hunk ./src/Network.hs 206
-nodeExists :: NodeNr -> Network a -> Bool
+nodeExists :: NodeNr -> Network g n e -> Bool
hunk ./src/Network.hs 211
-edgeExists :: EdgeNr -> Network a -> Bool
+edgeExists :: EdgeNr -> Network g n e -> Bool
hunk ./src/Network.hs 220
-addNode :: InfoKind a
- => Network a -- ^ the network to add the node to
- -> (NodeNr, Network a) -- ^ the number of the new node and
- -- the extended network
+addNode :: InfoKind n g
+ => Network g n e -- ^ the network to add the node to
+ -> (NodeNr, Network g n e) -- ^ the number of the new node and
+ -- the extended network
hunk ./src/Network.hs 231
-addNodes :: InfoKind a => Int -> Network a -> ([NodeNr], Network a)
+addNodes :: InfoKind n g => Int -> Network g n e -> ([NodeNr], Network g n e)
hunk ./src/Network.hs 238
-addNodeEx :: InfoKind a => String -> DoublePoint -> Network a
- -> (NodeNr, Network a)
+addNodeEx :: InfoKind n g => String -> DoublePoint -> Network g n e
+ -> (NodeNr, Network g n e)
hunk ./src/Network.hs 250
-addEdge :: NodeNr -> NodeNr -> Network a -> Network a
+addEdge :: InfoKind e g => NodeNr -> NodeNr -> Network g n e -> Network g n e
hunk ./src/Network.hs 257
- networkPlusEdge = network { networkEdges = insert edgeNr edge (networkEdges network) }
+ networkPlusEdge = network { networkEdges = insert edgeNr edge (networkEdges network) }
hunk ./src/Network.hs 260
- edge = Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr, edgeVia = [] }
+ edge = Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr
+ , edgeVia = [], edgeInfo = blank }
hunk ./src/Network.hs 264
-addEdges :: [(NodeNr,NodeNr)] -> Network a -> Network a
+addEdges :: InfoKind e g => [(NodeNr,NodeNr)] -> Network g n e -> Network g n e
hunk ./src/Network.hs 270
- -> Network a -> Network a
+ -> Network g n e -> Network g n e
hunk ./src/Network.hs 280
-removeNode :: NodeNr -> Network a -> Network a
+removeNode :: NodeNr -> Network g n e -> Network g n e
hunk ./src/Network.hs 293
-removeEdge :: EdgeNr -> Network a -> Network a
+removeEdge :: EdgeNr -> Network g n e -> Network g n e
hunk ./src/Network.hs 298
-removeAllEdges :: Network a -> Network a
+removeAllEdges :: Network g n e -> Network g n e
hunk ./src/Network.hs 304
-removeVia :: EdgeNr -> ViaNr -> Network a -> Network a
+removeVia :: EdgeNr -> ViaNr -> Network g n e -> Network g n e
hunk ./src/Network.hs 311
-setCanvasSize :: (Double, Double) -> Network a -> Network a
+setCanvasSize :: (Double, Double) -> Network g n e -> Network g n e
hunk ./src/Network.hs 314
+setGlobalInfo :: g -> Network g n e -> Network g n e
+setGlobalInfo info network = network { networkInfo = info }
+
hunk ./src/Network.hs 321
-sameFromAndTo :: Edge -> Edge -> Bool
+sameFromAndTo :: Edge e -> Edge e -> Bool
hunk ./src/Network.hs 325
-reverseEdge :: Edge -> Edge
+reverseEdge :: Edge e -> Edge e
hunk ./src/Network.hs 331
-updateNode :: NodeNr -> (Node.Node a -> Node.Node a) -> Network a -> Network a
+updateNode :: NodeNr -> (Node.Node n -> Node.Node n) -> Network g n e
+ -> Network g n e
hunk ./src/Network.hs 337
-updateVia :: EdgeNr -> ViaNr -> DoublePoint -> Network a -> Network a
+updateVia :: EdgeNr -> ViaNr -> DoublePoint -> Network g n e -> Network g n e
hunk ./src/NetworkControl.hs 11
+ , changeGlobalInfo
hunk ./src/NetworkControl.hs 18
- , removeNode, addNode)
+ , removeNode, addNode, getGlobalInfo, setGlobalInfo)
hunk ./src/NetworkControl.hs 33
-changeNamePosition :: Bool -> State a -> IO ()
+changeNamePosition :: Bool -> State g n e -> IO ()
hunk ./src/NetworkControl.hs 48
-changeNodeShape :: Shape -> State a -> IO ()
+changeNodeShape :: Shape -> State g n e -> IO ()
hunk ./src/NetworkControl.hs 63
-deleteSelection :: State a -> IO ()
+deleteSelection :: State g n e -> IO ()
hunk ./src/NetworkControl.hs 92
-createNode :: InfoKind a => DoublePoint -> State a -> IO ()
+createNode :: InfoKind n g => DoublePoint -> State g n e -> IO ()
hunk ./src/NetworkControl.hs 104
-selectEdge :: Int -> State a -> IO ()
+selectEdge :: Int -> State g n e -> IO ()
hunk ./src/NetworkControl.hs 111
-createEdge :: Int -> Int -> State a -> IO ()
+createEdge :: (InfoKind e g) => Int -> Int -> State g n e -> IO ()
hunk ./src/NetworkControl.hs 121
-createVia :: DoublePoint -> State a -> IO ()
+createVia :: DoublePoint -> State g n e -> IO ()
hunk ./src/NetworkControl.hs 140
-selectVia :: Int -> Int -> State a -> IO ()
+selectVia :: Int -> Int -> State g n e -> IO ()
hunk ./src/NetworkControl.hs 148
-pickupVia :: Int -> Int -> DoublePoint -> State a -> IO ()
+pickupVia :: Int -> Int -> DoublePoint -> State g n e -> IO ()
hunk ./src/NetworkControl.hs 158
-selectNode :: Int -> State a -> IO ()
+selectNode :: Int -> State g n e -> IO ()
hunk ./src/NetworkControl.hs 165
-pickupNode :: Int -> DoublePoint -> State a -> IO ()
+pickupNode :: Int -> DoublePoint -> State g n e -> IO ()
hunk ./src/NetworkControl.hs 175
-dragNode :: Int -> DoublePoint -> ScrolledWindow () -> State a -> IO ()
+dragNode :: Int -> DoublePoint -> ScrolledWindow () -> State g n e -> IO ()
hunk ./src/NetworkControl.hs 196
-dropNode :: Bool -> Int -> DoublePoint -> DoublePoint -> State a -> IO ()
+dropNode :: Bool -> Int -> DoublePoint -> DoublePoint -> State g n e -> IO ()
hunk ./src/NetworkControl.hs 210
-dragVia :: Int -> Int -> DoublePoint -> ScrolledWindow () -> State a -> IO ()
+dragVia :: Int -> Int -> DoublePoint -> ScrolledWindow () -> State g n e -> IO ()
hunk ./src/NetworkControl.hs 230
-dropVia :: Bool -> Int -> Int -> DoublePoint -> DoublePoint -> State a -> IO ()
+dropVia :: Bool -> Int -> Int -> DoublePoint -> DoublePoint -> State g n e -> IO ()
hunk ./src/NetworkControl.hs 244
-renameNode :: Frame () -> State a -> IO ()
+renameNode :: Frame () -> State g n e -> IO ()
hunk ./src/NetworkControl.hs 264
-reinfoNode :: InfoKind a => Frame () -> State a -> IO ()
+reinfoNode :: InfoKind n g => Frame () -> State g n e -> IO ()
hunk ./src/NetworkControl.hs 271
- do{ let oldInfo = Node.getInfo (getNode nodeNr network)
- ; result <- myTextDialog theFrame MultiLine
- "Edit node info" (show oldInfo) True
- ; ifJust result $ \newInfo ->
- case Parse.runParser Parse.parse newInfo of
- (Right x, s) ->
- do{ when (not (null s)) $
- errorDialog theFrame "Edit warning"
- ("Excess text after parsed value."
- ++"\nRemaining text: "++s)
- ; case check (Node.getName (getNode nodeNr network)) (Just x) of
- [] -> return ()
- e -> errorDialog theFrame "Validity warning"
- ("Validity check fails:\n"
- ++unlines e)
- ; PD.updateDocument "edit node info"
- (updateNetwork [_$_]
- (updateNode nodeNr (Node.setInfo x))) pDoc
- ; repaintAll state
- }
- (Left err,s) -> errorDialog theFrame "Edit warning"
- ("Cannot parse entered text."
- ++"\nReason: "++err
- ++"\nRemaining text: "++s)
- }
+ do{ let oldInfo = Node.getInfo (getNode nodeNr network)
+ ; result <- myTextDialog theFrame MultiLine
+ "Edit node info" (show oldInfo) True
+ ; ifJust result $ \newInfo ->
+ case Parse.runParser Parse.parse newInfo of
+ (Right x, s) ->
+ do{ when (not (null s)) $
+ errorDialog theFrame "Edit warning"
+ ("Excess text after parsed value."
+ ++"\nRemaining text: "++s)
+ ; case check (Node.getName (getNode nodeNr network))
+ (getGlobalInfo network) x of
+ [] -> return ()
+ e -> errorDialog theFrame "Validity warning"
+ ("Validity check fails:\n"
+ ++unlines e)
+ ; PD.updateDocument "edit node info"
+ (updateNetwork [_$_]
+ (updateNode nodeNr (Node.setInfo x))) pDoc
+ ; repaintAll state
+ }
+ (Left err,s) -> errorDialog theFrame "Edit warning"
+ ("Cannot parse entered text."
+ ++"\nReason: "++err
+ ++"\nRemaining text: "++s)
+ }
hunk ./src/NetworkControl.hs 298
+ }
+
+changeGlobalInfo :: (Show g, Parse g) => Frame () -> State g n e -> IO ()
+changeGlobalInfo theFrame state = [_$_]
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; let network = getNetwork doc
+ ; let info = show (getGlobalInfo network)
+ ; result <- myTextDialog theFrame MultiLine "Edit global info" info True
+ ; ifJust result $ \newInfo->
+ case Parse.runParser Parse.parse newInfo of
+ (Right x, s) ->
+ do{ when (not (null s)) $
+ errorDialog theFrame "Edit warning"
+ ("Excess text after parsed value."
+ ++"\nRemaining text: "++s)
+ ; PD.updateDocument "edit global info"
+ (updateNetwork (setGlobalInfo x)) pDoc
+ ; repaintAll state -- no visible change?
+ }
+ (Left err,s) -> errorDialog theFrame "Edit warning"
+ ("Cannot parse entered text."
+ ++"\nReason: "++err
+ ++"\nRemaining text: "++s)
hunk ./src/NetworkFile.hs 13
-import Text.XML.HaXml.Lex (noPos)
+import Text.XML.HaXml.Posn (noPos)
hunk ./src/NetworkFile.hs 26
-toString :: InfoKind a => Network a -> String
+toString :: (InfoKind n g, InfoKind e g, Haskell2XmlNew g) =>
+ Network g n e -> String
hunk ./src/NetworkFile.hs 32
+ f _ = error "bad" -- shouldn't happen
hunk ./src/NetworkFile.hs 38
-fromString :: InfoKind a => String -> Either String (Network a, [String], Bool)
+fromString :: (InfoKind n g, InfoKind e g, Haskell2XmlNew g) =>
+ String -> Either String (Network g n e, [String], Bool)
hunk ./src/NetworkFile.hs 48
+{-
hunk ./src/NetworkFile.hs 50
-toStringShow :: Network String -> String
+toStringShow :: (Show g, Show n, Show e) => Network g n e -> String
hunk ./src/NetworkFile.hs 55
+ , getGlobalInfo network
hunk ./src/NetworkFile.hs 58
-fromStringShow :: String -> Either String (Network String)
+fromStringShow :: (Read g, InfoKind n g, InfoKind e g) =>
+ String -> Either String (Network g n e)
hunk ./src/NetworkFile.hs 63
- let (nodeAssocs, edgeAssocs, canvasSize) = tuple
+ let (nodeAssocs, edgeAssocs, canvasSize, globalInfo) = tuple
hunk ./src/NetworkFile.hs 67
- $ Network.empty
+ $ Network.empty globalInfo undefined undefined
hunk ./src/NetworkFile.hs 70
+-}
hunk ./src/NetworkFile.hs 76
-data AssocN a = AssocN Int (Node a)
-deAssocN :: AssocN a -> (Int,Node a)
+data AssocN n = AssocN Int (Node n)
+deAssocN :: AssocN n -> (Int,Node n)
hunk ./src/NetworkFile.hs 79
-data AssocE = AssocE Int Edge
-deAssocE :: AssocE -> (Int,Edge)
+data AssocE e = AssocE Int (Edge e)
+deAssocE :: AssocE e -> (Int,Edge e)
hunk ./src/NetworkFile.hs 86
-instance (Haskell2XmlNew a, InfoKind a) => Haskell2XmlNew (Network a) where
+instance (InfoKind n g, InfoKind e g, Haskell2XmlNew g) =>
+ Haskell2XmlNew (Network g n e) where
hunk ./src/NetworkFile.hs 95
+ , makeTag "Info" (toContents netInfo)
hunk ./src/NetworkFile.hs 103
+ netInfo = getGlobalInfo network
hunk ./src/NetworkFile.hs 106
- { w <- element' ["Width"] $ fmap read XML.text
+ { w <- element' ["Width"] $ fmap read XML.text
hunk ./src/NetworkFile.hs 108
- ; ns <- element' ["Nodes"] $ nonemptylist parseContents
- ; es <- element' ["Edges"] $ nonemptylist parseContents
+ ; i <- element' ["Info"] $ parseContents
+ ; ns <- element' ["Nodes"] $ nonemptylist parseContents
+ ; es <- element' ["Edges"] $ nonemptylist parseContents
hunk ./src/NetworkFile.hs 115
- $ Network.empty)
+ $ Network.empty i undefined undefined)
hunk ./src/NetworkFile.hs 119
-instance (Haskell2XmlNew a, InfoKind a) => Haskell2XmlNew (AssocN a) where
+instance (InfoKind n g) => Haskell2XmlNew (AssocN n) where
hunk ./src/NetworkFile.hs 134
-instance Haskell2XmlNew AssocE where
+instance (InfoKind e g) => Haskell2XmlNew (AssocE e) where
hunk ./src/NetworkFile.hs 149
-instance (Haskell2XmlNew a, InfoKind a) => Haskell2XmlNew (Node a) where
+instance (InfoKind n g) => Haskell2XmlNew (Node n) where
hunk ./src/NetworkFile.hs 190
-instance Haskell2XmlNew Edge where
+instance InfoKind e g => Haskell2XmlNew (Edge e) where
hunk ./src/NetworkFile.hs 199
+ , makeTag "Info" (toContents (edgeInfo edge))
hunk ./src/NetworkFile.hs 207
- ; return (Edge { edgeFrom=f, edgeTo=t, edgeVia=v })
+ ; i <- element' ["Info"] $ parseContents
+ ; return (Edge { edgeFrom=f, edgeTo=t, edgeVia=v, edgeInfo=i })
hunk ./src/NetworkFile.hs 339
-networkValid :: [AssocN a] -> [AssocE] -> XMLParser ()
+networkValid :: [AssocN n] -> [AssocE e] -> XMLParser ()
hunk ./src/NetworkFile.hs 348
- ; let multipleEdges = duplicates (map sortEdge edges)
+ ; let multipleEdges = duplicatesBy semiEq (map sortEdge edges)
hunk ./src/NetworkFile.hs 352
- | Edge f t _ <- multipleEdges
+ | Edge f t _ _ <- multipleEdges
hunk ./src/NetworkFile.hs 362
-checkEdge :: [NodeNr] -> AssocE -> XMLParser ()
-checkEdge nodeNrs (AssocE edgeNr (Edge fromNr toNr _))
+checkEdge :: [NodeNr] -> AssocE e -> XMLParser ()
+checkEdge nodeNrs (AssocE edgeNr (Edge fromNr toNr _ _))
hunk ./src/NetworkFile.hs 377
--- Funny function that possibly flips an edge so that the from node number
+-- Funny function that possibly flips an edge so that the from-node number
hunk ./src/NetworkFile.hs 379
-sortEdge :: Edge -> Edge
-sortEdge (Edge f t v) | f < t = Edge f t v
- | otherwise = Edge t f v
+sortEdge :: Edge e -> Edge e
+sortEdge (Edge f t v i) | f < t = Edge f t v i
+ | otherwise = Edge t f v i
+
+-- Partial equality on edges
+semiEq :: Edge e -> Edge e -> Bool
+semiEq (Edge f t _ _) (Edge f' t' _ _) = f==f' && t==t'
hunk ./src/NetworkFile.hs 393
+
+-- Returns elements that appear more than once in a list, using given Eq op
+duplicatesBy :: (a->a->Bool) -> [a] -> [a]
+duplicatesBy _ [] = []
+duplicatesBy eq (x:xs)
+ | any (eq x) xs = x : duplicatesBy eq (filter (not . eq x) xs)
+ | otherwise = duplicatesBy eq xs
+
hunk ./src/NetworkUI.hs 21
+import Text.XML.HaXml.Haskell2XmlNew (Haskell2XmlNew)
+import Parse
+import Analysis
+import NetworkControl (changeGlobalInfo)
hunk ./src/NetworkUI.hs 37
-getConfig :: State a -> IO Config
+getConfig :: State g n e -> IO Config
hunk ./src/NetworkUI.hs 52
-create :: InfoKind a => State a -> a -> IO ()
-create state _ =
+create :: (Analysis g n e, Haskell2XmlNew g, Parse g, Show g, Read n) =>
+ State g n e -> g -> n -> e -> IO ()
+create state g n e =
hunk ./src/NetworkUI.hs 67
- ; let (width, height) = getCanvasSize Network.empty
+ ; let (width, height) = getCanvasSize (Network.empty g n e)
hunk ./src/NetworkUI.hs 166
+ [ text := "Edit global info..."
+ , on command := safetyNet theFrame $ changeGlobalInfo theFrame state
+ ]
+ ; menuItem editMenu
hunk ./src/NetworkUI.hs 173
+ ; menuLine editMenu
+ ; menuItem editMenu
+ [ text := "Perform analysis"
+ , on command := safetyNet theFrame $ do
+ { callAnalysis state; repaintAll state }
+ ]
hunk ./src/NetworkUI.hs 182
- ; menuItem viewMenu
- [ text := "Label only"
+ ; (DP opts) <- getDisplayOptions state
+ ; menuRadioItem viewMenu
+ [ text := "Node Labels"
+ , checked := NodeLabel `elem` opts
hunk ./src/NetworkUI.hs 187
- { setDisplayOptions (DP Label) state
+ { changeDisplayOptions (toggle NodeLabel) state
hunk ./src/NetworkUI.hs 189
- ; menuItem viewMenu
- [ text := "Info only"
+ ; menuRadioItem viewMenu
+ [ text := "Node Info"
+ , checked := NodeInfo `elem` opts
hunk ./src/NetworkUI.hs 193
- { setDisplayOptions (DP Info) state
+ { changeDisplayOptions (toggle NodeInfo) state
hunk ./src/NetworkUI.hs 195
- ; menuItem viewMenu
- [ text := "Label + Info"
+ ; menuRadioItem viewMenu
+ [ text := "Edge Info"
+ , checked := EdgeInfo `elem` opts
hunk ./src/NetworkUI.hs 199
- { setDisplayOptions (DP LabelAndInfo) state
+ { changeDisplayOptions (toggle EdgeInfo) state
hunk ./src/NetworkUI.hs 203
- { PD.document = Document.empty
+ { PD.document = Document.empty g n e
hunk ./src/NetworkUI.hs 231
-paintHandler :: InfoKind a => State a -> DC () -> IO ()
+paintHandler :: (InfoKind n g, InfoKind e g) =>
+ State g n e -> DC () -> IO ()
hunk ./src/NetworkUI.hs 243
-mouseEvent :: InfoKind a =>
- EventMouse -> ScrolledWindow () -> Frame () -> State a -> IO ()
+mouseEvent :: (InfoKind n g, InfoKind e g, Show g, Parse g) =>
+ EventMouse -> ScrolledWindow () -> Frame () -> State g n e -> IO ()
hunk ./src/NetworkUI.hs 258
-keyboardEvent :: InfoKind a => Frame () -> State a -> EventKey -> IO ()
+keyboardEvent :: (InfoKind n g) => Frame () -> State g n e -> EventKey -> IO ()
hunk ./src/NetworkUI.hs 270
-closeDocAndThen :: State a -> IO () -> IO ()
+closeDocAndThen :: State g n e -> IO () -> IO ()
hunk ./src/NetworkUI.hs 277
-newItem :: State a -> IO ()
+newItem :: (InfoKind n g, InfoKind e g) => State g n e -> IO ()
hunk ./src/NetworkUI.hs 281
- ; PD.resetDocument Nothing Document.empty pDoc
+ ; PD.resetDocument Nothing (Document.empty undefined undefined undefined) pDoc
hunk ./src/NetworkUI.hs 285
-openItem :: InfoKind a => Frame () -> State a -> IO ()
+openItem :: (InfoKind n g, InfoKind e g, Haskell2XmlNew g) =>
+ Frame () -> State g n e -> IO ()
hunk ./src/NetworkUI.hs 300
-openNetworkFile :: InfoKind a => String -> State a -> Maybe (Frame ()) -> IO ()
+openNetworkFile :: (InfoKind n g, InfoKind e g, Haskell2XmlNew g) =>
+ String -> State g n e -> Maybe (Frame ()) -> IO ()
hunk ./src/NetworkUI.hs 317
- ; let newDoc = setNetwork network Document.empty
+ ; let newDoc = setNetwork network (Document.empty undefined undefined undefined)
hunk ./src/NetworkUI.hs 356
-openPalette :: InfoKind a => Frame () -> State a -> IO ()
+openPalette :: (InfoKind n g, Read n) => Frame () -> State g n e -> IO ()
hunk ./src/NetworkUI.hs 370
-openPaletteFile :: InfoKind a => String -> State a -> Maybe (Frame ()) -> IO ()
+openPaletteFile :: (InfoKind n g, Read n) =>
+ String -> State g n e -> Maybe (Frame ()) -> IO ()
hunk ./src/NetworkUI.hs 388
-applyCanvasSize :: State a -> IO ()
+applyCanvasSize :: State g n e -> IO ()
hunk ./src/NetworkUI.hs 400
-saveToDisk :: InfoKind a => Frame () -> String -> Document.Document a -> IO Bool
+saveToDisk :: (InfoKind n g, InfoKind e g, Haskell2XmlNew g) =>
+ Frame () -> String -> Document.Document g n e -> IO Bool
hunk ./src/NetworkUI.hs 405
-exit :: State a -> IO ()
+exit :: State g n e -> IO ()
hunk ./src/NetworkView.hs 30
-drawCanvas :: InfoKind a => Document a -> DC () -> DisplayOptions -> IO ()
+drawCanvas :: (InfoKind n g, InfoKind e g) =>
+ Document g n e -> DC () -> DisplayOptions -> IO ()
hunk ./src/NetworkView.hs 51
-reallyDrawCanvas :: InfoKind a
- => Document a -> Size -> DC () -> DisplayOptions -> IO ()
+reallyDrawCanvas :: (InfoKind n g, InfoKind e g) =>
+ Document g n e -> Size -> DC () -> DisplayOptions -> IO ()
hunk ./src/NetworkView.hs 87
- ; when (dpShowInfo opt `elem` [Label,LabelAndInfo]) $
+ ; when (NodeLabel `elem` dpShowInfo opt) $
hunk ./src/NetworkView.hs 90
- ; when (dpShowInfo opt `elem` [Info,LabelAndInfo]) $
+ ; when (NodeInfo `elem` dpShowInfo opt) $
hunk ./src/NetworkView.hs 104
- then y - kNODE_RADIUS - kARROW_SIZE - textHeight
- else y + kNODE_RADIUS + kARROW_SIZE
+ then y - kNODE_RADIUS {- - kARROW_SIZE -} - textHeight
+ else y + kNODE_RADIUS {- + kARROW_SIZE -}
hunk ./src/NetworkView.hs 107
- horizontalMargin = 0.2 -- centimeters
- verticalMargin = 0.01 -- centimeters
- ; logicalRect ppi dc
- (textX - horizontalMargin) textY
- (textWidth+2*horizontalMargin) (textHeight+2*verticalMargin)
- (solidFill labelBackgroundColor)
+ -- horizontalMargin = 0.2 -- centimeters
+ -- verticalMargin = 0.01 -- centimeters
+ -- ; logicalRect ppi dc
+ -- (textX - horizontalMargin) textY
+ -- (textWidth+2*horizontalMargin) (textHeight+2*verticalMargin)
+ -- (solidFill labelBackgroundColor)
hunk ./src/NetworkView.hs 117
- drawEdge :: Edge -> [Prop (DC ())] -> IO ()
- drawEdge
- (Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr, edgeVia = via })
- options =
+ drawEdge :: InfoKind e g => Edge e -> [Prop (DC ())] -> IO ()
+ drawEdge (Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr
+ , edgeVia = via, edgeInfo = info })
+ options =
hunk ./src/NetworkView.hs 122
+ -- arrow on the end
hunk ./src/NetworkView.hs 124
+ -- draw info
+ ; when (EdgeInfo `elem` dpShowInfo opt) $
+ drawLabel True (show info) (middle via)
hunk ./src/NetworkView.hs 145
+ middle [] = DoublePoint ((doublePointX pt1 + doublePointX pt2)/2)
+ ((doublePointY pt1 + doublePointY pt2)/2)
+ middle [p] = p
+ middle ps = middle (tail (reverse ps))
+
hunk ./src/NetworkView.hs 156
- drawVia :: Edge -> ViaNr -> [Prop (DC ())] -> IO ()
+ drawVia :: Edge e -> ViaNr -> [Prop (DC ())] -> IO ()
hunk ./src/NetworkView.hs 166
-clickedNode :: DoublePoint -> Document a -> Maybe Int
+clickedNode :: DoublePoint -> Document g n e -> Maybe Int
hunk ./src/NetworkView.hs 177
-nodeContains :: Node.Node a -> DoublePoint -> Bool
+nodeContains :: Node.Node n -> DoublePoint -> Bool
hunk ./src/NetworkView.hs 183
-clickedEdge :: DoublePoint -> Network a -> Maybe Int
+clickedEdge :: DoublePoint -> Network g n e -> Maybe Int
hunk ./src/NetworkView.hs 190
-edgeContains :: Edge -> DoublePoint -> Network a -> Maybe Int
+edgeContains :: Edge e -> DoublePoint -> Network g n e -> Maybe Int
hunk ./src/NetworkView.hs 206
-clickedVia :: DoublePoint -> Network a -> Maybe (Int,Int)
+clickedVia :: DoublePoint -> Network g n e -> Maybe (Int,Int)
hunk ./src/Node.hs 16
-data Node a = Node
+data Node n = Node
hunk ./src/Node.hs 21
- , nodeInfo :: a
+ , nodeInfo :: n
hunk ./src/Node.hs 24
-create :: InfoKind a => String -> DoublePoint -> Bool -> Node a
+create :: (InfoKind n g) => String -> DoublePoint -> Bool -> Node n
hunk ./src/Parse.hs 26
-class Read a => Parse a where
+class Parse a where
hunk ./src/Parse.hs 28
- -- default method re-uses the Read class, but custom instances ought to
- -- use more intelligence.
- parse = P (\ts-> case reads ts of
- [] -> (Left "no parse", ts)
- [(a,xs)] -> (Right a, xs)
- _ -> (Left "ambiguous parse", ts) )
+-- -- default method re-uses the Read class, but custom instances ought to
+-- -- use more intelligence.
+-- parse = P (\ts-> case reads ts of
+-- [] -> (Left "no parse", ts)
+-- [(a,xs)] -> (Right a, xs)
+-- _ -> (Left "ambiguous parse", ts) )
hunk ./src/Parse.hs 43
-instance (Read a, Parse a) => Parse (Maybe a) where
- parse = P p
- where p [] = (Left "no input: expected a Maybe value", [])
- p ts = case reads ts of
- [] -> (Left "no parse, expected a Maybe", ts)
- [(a,xs)] -> (Right a, xs)
- _ -> (Left "ambiguous parse for Maybe", ts)
+instance Parse a => Parse (Maybe a) where
+ parse = fmap Just parse `onfail` return Nothing
+-- parse = P p
+-- where p [] = (Left "no input: expected a Maybe value", [])
+-- p ts = case reads ts of
+-- [] -> (Left "no parse, expected a Maybe", ts)
+-- [(a,xs)] -> (Right a, xs)
+-- _ -> (Left "ambiguous parse for Maybe", ts)
hunk ./src/State.hs 13
+ , changeDisplayOptions
hunk ./src/State.hs 25
-type State a = Var (StateRecord a)
+type State g n e = Var (StateRecord g n e)
hunk ./src/State.hs 27
-data StateRecord a = St
- { stDocument :: PD.PersistentDocument (Document a)
+data StateRecord g n e = St
+ { stDocument :: PD.PersistentDocument (Document g n e)
hunk ./src/State.hs 33
- , stPalette :: Palette.Palette a -- available node shapes/types
+ , stPalette :: Palette.Palette n -- available node shapes/types
hunk ./src/State.hs 42
-empty :: IO (State a)
+empty :: IO (State g n e)
hunk ./src/State.hs 59
-getDocument :: State a -> IO (PD.PersistentDocument (Document a))
+getDocument :: State g n e -> IO (PD.PersistentDocument (Document g n e))
hunk ./src/State.hs 62
-getDragging :: State a -> IO (Maybe (Bool, DoublePoint))
+getDragging :: State g n e -> IO (Maybe (Bool, DoublePoint))
hunk ./src/State.hs 65
-getNetworkFrame :: State a -> IO (Frame ())
+getNetworkFrame :: State g n e -> IO (Frame ())
hunk ./src/State.hs 68
-getCanvas :: State a -> IO (ScrolledWindow ())
+getCanvas :: State g n e -> IO (ScrolledWindow ())
hunk ./src/State.hs 71
-getPageSetupDialog :: State a -> IO (PageSetupDialog ())
+getPageSetupDialog :: State g n e -> IO (PageSetupDialog ())
hunk ./src/State.hs 74
-getPalette :: State a -> IO (Palette.Palette a)
+getPalette :: State g n e -> IO (Palette.Palette n)
hunk ./src/State.hs 77
-getDisplayOptions :: State a -> IO DisplayOptions
+getDisplayOptions :: State g n e -> IO DisplayOptions
hunk ./src/State.hs 82
-setDragging :: Maybe (Bool, DoublePoint) -> State a -> IO ()
+setDragging :: Maybe (Bool, DoublePoint) -> State g n e -> IO ()
hunk ./src/State.hs 86
-setNetworkFrame :: Frame () -> State a -> IO ()
+setNetworkFrame :: Frame () -> State g n e -> IO ()
hunk ./src/State.hs 90
-setCanvas :: ScrolledWindow () -> State a -> IO ()
+setCanvas :: ScrolledWindow () -> State g n e -> IO ()
hunk ./src/State.hs 94
-setPageSetupDialog :: PageSetupDialog () -> State a -> IO ()
+setPageSetupDialog :: PageSetupDialog () -> State g n e -> IO ()
hunk ./src/State.hs 98
-setPalette :: Palette.Palette a -> State a -> IO ()
+setPalette :: Palette.Palette n -> State g n e -> IO ()
hunk ./src/State.hs 102
-setDisplayOptions :: DisplayOptions -> State a -> IO ()
+setDisplayOptions :: DisplayOptions -> State g n e -> IO ()
hunk ./src/State.hs 106
+changeDisplayOptions :: (DisplayOptions->DisplayOptions) -> State g n e -> IO ()
+changeDisplayOptions dpf stateRef =
+ varUpdate_ stateRef
+ (\state -> state { stDisplayOptions = dpf (stDisplayOptions state) })
+
hunk ./src/State.hs 113
-getFromState :: (StateRecord b -> a) -> State b -> IO a
+getFromState :: (StateRecord g n e -> a) -> State g n e -> IO a
hunk ./src/StateUtil.hs 13
-repaintAll :: State a -> IO ()
+repaintAll :: State g n e -> IO ()
hunk ./src/StateUtil.hs 19
-getNetworkName :: State a -> IO String
+getNetworkName :: State g n e -> IO String
}