summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Grasp/Monad.hs196
1 files changed, 106 insertions, 90 deletions
diff --git a/src/Grasp/Monad.hs b/src/Grasp/Monad.hs
index 9780741..b49b53d 100644
--- a/src/Grasp/Monad.hs
+++ b/src/Grasp/Monad.hs
@@ -60,45 +60,70 @@ import qualified Grasp.Types.EdgeLabel as EL
-type GraspM a = StateT GraspProgram IO a
+type GraspM a = StateT (Gr Instruction EdgeLabel, [IP], Map FilePath Handle) IO a
-data GraspProgram = GraspProgram { programGraph :: Gr Instruction EdgeLabel
- , instPtrs :: [IP]
- , fileHandles :: Map FilePath Handle }
- deriving (Show, Eq)
-
+-- wrapping and unwrapping
construct :: ([GNode],[GEdge]) -> GraspM ()
-construct (n,e) = do
- Monad.when (multiNodes n) (error "node declared multiple times")
- Monad.when (unconnected n e) (error "unconnected edge")
- Monad.when (multiNames n e) (error "node with multiple names")
- Monad.when (numericName n e) (error "node with a numeric name")
- Monad.when (noMain n e) (error "could not find grasp:main")
-
- let graph = Graph.mkGraph (map GN.toLNode n) (map GE.toLEdge e)
- ips = map IP.singleton (nodesWithName n e "grasp:main")
+construct (ns,es) = do
+ Monad.when (multiNodes ns) (error "node declared multiple times")
+ Monad.when (unconnected ns es) (error "unconnected edge")
+ Monad.when (multiNames ns es) (error "node with multiple names")
+ Monad.when (numericName ns es) (error "node with a numeric name")
+ Monad.when (noMain ns es) (error "could not find grasp:main")
+
+ let graph = Graph.mkGraph (map GN.toLNode ns) (map GE.toLEdge es)
+ ips = map IP.singleton (nodesWithName ns es "grasp:main")
handles = Map.empty
- State.put (GraspProgram graph ips handles)
+ State.put (graph, ips, handles)
finalise :: GraspM () -> IO ([GNode],[GEdge])
finalise s = do
- p <- State.execStateT s (GraspProgram Graph.empty [] Map.empty)
- (mapM_ IO.hClose) . Map.elems . fileHandles $ p
- let gr = programGraph p
- (nodes, edges) = (Graph.labNodes gr, Graph.labEdges gr)
+ (gr, ips, fh) <- State.execStateT s (Graph.empty, [], Map.empty)
+ (mapM_ IO.hClose) . Map.elems $ fh
+ let (nodes, edges) = (Graph.labNodes gr, Graph.labEdges gr)
return (map GN.mk nodes, map GE.mk edges)
+
+
+-- internally used functions
+
+
+-- fix this later so it doesn't required unconnected edge checking first
+nameNodeList :: [GNode] -> [GEdge] -> [(GNode,GNode)]
+nameNodeList ns es =
+ let nameEdges = filter ((== (EL.mk "name")) . GE.toLabel) es
+ findNode n = Maybe.fromJust (List.find ((== n) . GN.toNode) ns)
+ in map (\x -> (findNode (GE.toSrc x), findNode (GE.toDest x))) nameEdges
+
+
+
+nodesWithName :: [GNode] -> [GEdge] -> String -> [GNode]
+nodesWithName ns es name =
+ (map fst) . (filter (\x -> (GN.toInst . snd $ x) == (IN.mk name))) $ (nameNodeList ns es)
+
+
+
+namedNodes :: [GNode] -> [GEdge] -> [GNode]
+namedNodes ns es = map fst (nameNodeList ns es)
+
+
+
+
+
+-- error checking when setting up
+
+
multiNodes :: [GNode] -> Bool
multiNodes ns = (ns == (List.nubBy (\x y -> GN.toNode x == GN.toNode y) ns))
@@ -134,15 +159,50 @@ noMain ns es =
+
+
+-- garbage collection
+
+
+garbageCollect :: Gr Instruction EdgeLabel -> [IP] -> Gr Instruction EdgeLabel
+garbageCollect gr ips =
+ let unreachable = (Graph.nodes gr) \\ (reachable gr ips)
+ in Graph.delNodes unreachable gr
+
+
+
+reachable :: Gr Instruction EdgeLabel -> [IP] -> [Node]
+reachable gr ips =
+ let named = namedNodes (map GN.mk (Graph.labNodes gr)) (map GE.mk (Graph.labEdges gr))
+ ipNodes = concatMap IP.toList ips
+ start = (map GN.toNode) . List.nub $ named ++ ipNodes
+ in reach gr start []
+
+
+
+reach :: Gr Instruction EdgeLabel -> [Node] -> [Node] -> [Node]
+reach _ [] f = f
+reach gr (x:xs) f =
+ let f' = List.nub (x:f)
+ x' = List.nub (xs ++ (Graph.suc gr x))
+ gr' = Graph.delNode x gr
+ in reach gr' x' f'
+
+
+
+
+
+-- I/O
+
+
getWriteHandle :: FilePath -> GraspM Handle
getWriteHandle path = do
- program <- State.get
- let (gr, ptrs, handles) = ((programGraph program), (instPtrs program), (fileHandles program))
+ (gr, ips, fh) <- State.get
- case (Map.lookup path handles) of
+ case (Map.lookup path fh) of
Nothing -> do
h <- liftIO (IO.openFile path IO.AppendMode)
- State.put (GraspProgram gr ptrs (Map.insert path h handles))
+ State.put (gr, ips, (Map.insert path h fh))
return h
Just x -> do
@@ -150,7 +210,7 @@ getWriteHandle path = do
if (not w) then do
liftIO (IO.hClose x)
h <- liftIO (IO.openFile path IO.AppendMode)
- State.put (GraspProgram gr ptrs (Map.insert path h handles))
+ State.put (gr, ips, (Map.insert path h fh))
return h
else return x
@@ -158,13 +218,12 @@ getWriteHandle path = do
getReadHandle :: FilePath -> GraspM Handle
getReadHandle path = do
- program <- State.get
- let (gr, ptrs, handles) = ((programGraph program), (instPtrs program), (fileHandles program))
+ (gr, ips, fh) <- State.get
- case (Map.lookup path (fileHandles program)) of
+ case (Map.lookup path fh) of
Nothing -> do
h <- liftIO (IO.openFile path IO.ReadMode)
- State.put (GraspProgram gr ptrs (Map.insert path h handles))
+ State.put (gr, ips, (Map.insert path h fh))
return h
Just x -> do
@@ -172,122 +231,79 @@ getReadHandle path = do
if (not r) then do
liftIO (IO.hClose x)
h <- liftIO (IO.openFile path IO.ReadMode)
- State.put (GraspProgram gr ptrs (Map.insert path h handles))
+ State.put (gr, ips, (Map.insert path h fh))
return h
else return x
--- fix this later so it doesn't required unconnected edge checking first
-nameNodeList :: [GNode] -> [GEdge] -> [(GNode,GNode)]
-nameNodeList ns es =
- let nameEdges = filter ((== (EL.mk "name")) . GE.toLabel) es
- findNode n = Maybe.fromJust (List.find ((== n) . GN.toNode) ns)
- in map (\x -> (findNode (GE.toSrc x), findNode (GE.toDest x))) nameEdges
-
-
-
-nodesWithName :: [GNode] -> [GEdge] -> String -> [GNode]
-nodesWithName ns es name =
- (map fst) . (filter (\x -> (GN.toInst . snd $ x) == (IN.mk name))) $ (nameNodeList ns es)
-
-
-namedNodes :: [GNode] -> [GEdge] -> [GNode]
-namedNodes ns es = map fst (nameNodeList ns es)
+-- manipulating the instruction pointers
updateIP :: GraspM ()
updateIP = do
- program <- State.get
+ (gr, ips, fh) <- State.get
curNode <- peekIP
Monad.when (Maybe.isJust curNode) (do
nexts <- nodesOut (EL.mk "next") (Maybe.fromJust curNode)
r <- liftIO (Random.getStdRandom (Random.randomR (0, length nexts - 1)))
- let ips = instPtrs program
- updated = if (length nexts == 0) then IP.empty else IP.shift (nexts !! r) (head ips)
+ let updated = if (length nexts == 0) then IP.empty else IP.shift (nexts !! r) (head ips)
ips' = updated:(tail ips)
- State.put (GraspProgram (programGraph program) ips' (fileHandles program)) )
+ State.put (gr, ips', fh) )
pushIP :: GNode -> GraspM ()
pushIP n = do
- program <- State.get
- let ips = instPtrs program
- ips' = if (length ips == 0) then [] else (IP.push n (head ips)):(tail ips)
- State.put (GraspProgram (programGraph program) ips' (fileHandles program))
+ (gr, ips, fh) <- State.get
+ let ips' = if (length ips == 0) then [] else (IP.push n (head ips)):(tail ips)
+ State.put (gr, ips', fh)
popIP :: GraspM ()
popIP = do
- program <- State.get
- let ips = instPtrs program
- ips' = if (length ips == 0) then [] else (IP.pop (head ips)):(tail ips)
- State.put (GraspProgram (programGraph program) ips' (fileHandles program))
+ (gr, ips, fh) <- State.get
+ let ips' = if (length ips == 0) then [] else (IP.pop (head ips)):(tail ips)
+ State.put (gr, ips', fh)
peekIP :: GraspM (Maybe GNode)
peekIP = do
- program <- State.get
- let ips = instPtrs program
+ (gr, ips, fh) <- State.get
if (length ips == 0) then return Nothing else return (IP.peek (head ips))
nextIP :: GraspM ()
nextIP = do
- program <- State.get
- let ips = instPtrs program
- gr = programGraph program
- ips' = if (length ips == 0)
+ (gr, ips, fh) <- State.get
+ let ips' = if (length ips == 0)
then []
else if (IP.isEmpty (head ips))
then tail ips
else (tail ips) ++ [head ips]
gr' = garbageCollect gr ips'
- State.put (GraspProgram gr' ips' (fileHandles program))
+ State.put (gr', ips', fh)
-garbageCollect :: Gr Instruction EdgeLabel -> [IP] -> Gr Instruction EdgeLabel
-garbageCollect gr ips =
- let unreachable = (Graph.nodes gr) \\ (reachable gr ips)
- in Graph.delNodes unreachable gr
-
-reachable :: Gr Instruction EdgeLabel -> [IP] -> [Node]
-reachable gr ips =
- let named = namedNodes (map GN.mk (Graph.labNodes gr)) (map GE.mk (Graph.labEdges gr))
- ipNodes = concatMap IP.toList ips
- start = (map GN.toNode) . List.nub $ named ++ ipNodes
- in reach gr start []
-
-
-
-reach :: Gr Instruction EdgeLabel -> [Node] -> [Node] -> [Node]
-reach _ [] f = f
-reach gr (x:xs) f =
- let f' = List.nub (x:f)
- x' = List.nub (xs ++ (Graph.suc gr x))
- gr' = Graph.delNode x gr
- in reach gr' x' f'
-
+-- accessing and manipulating the graph
nodesOut :: EdgeLabel -> GNode -> GraspM [GNode]
nodesOut s n = do
- program <- State.get
+ (gr, ips, fh) <- State.get
curNode <- peekIP
- let gr = programGraph program
- nout = Graph.lsuc gr (GN.toNode (Maybe.fromJust curNode))
+ let nout = Graph.lsuc gr (GN.toNode (Maybe.fromJust curNode))
filtered = filter ((== s) . snd) nout
result = map (\(x,y) -> GN.mk (x, Maybe.fromJust (Graph.lab gr x))) filtered
generated by cgit (git 2.30.0) at 2024-12-22 17:48:45 +0000