diff --git a/Data/FsmActions.hs b/Data/FsmActions.hs --- a/Data/FsmActions.hs +++ b/Data/FsmActions.hs @@ -141,7 +141,7 @@ -- | Compute the 'DestinationSet' reached by following some 'Action' -- from some 'State'. actionLookup :: Action -> State -> DestinationSet -actionLookup (Action ds) src = ds !! src +actionLookup (Action ds) = (ds !!) -- | Compute the 'Action' for some 'Word' over some 'FSM'. The word -- might contain symbols outside the FSM's alphabet, so the result diff --git a/Data/FsmActions/ActionMatrix.hs b/Data/FsmActions/ActionMatrix.hs --- a/Data/FsmActions/ActionMatrix.hs +++ b/Data/FsmActions/ActionMatrix.hs @@ -11,27 +11,50 @@ than one 1, the corresponding 'Data.FsmActions.Action' and 'Data.FsmActions.FSM' will be nondeterministic. +An ActionSpecFile is a list of (symbol string, path to ActionMatrix +file) pairs. Its syntax is as follows: + + - Symbols, and paths, should all be enclosed in double quotes (with + the nice side-effect that spaces are thus allowed). + + - A symbol/path pair is separated by whitespace. + + - The list of symbol/path pairs is delimited by semicolons (and + optional whitespace). A trailing semicolon is optional. + + - Line comments, starting with -- (as in Haskell), are allowed + anywhere whitespace is allowed. + -} module Data.FsmActions.ActionMatrix ( - -- * Input + -- * I/O + loadActionMxFsm, + saveActionMxFsm, + -- * Parsing parseFsmActionMxFiles, - parseActionMxFile, + parseFsmActionMxs, parseActionMx, - -- * Output + -- * Pretty-printing + printFsmActionMx, printActionMx ) where +import Control.Arrow (second) +import Control.Exception import Control.Monad.Error import qualified Data.List as L +import Data.String.Utils import Data.Maybe (mapMaybe) -import System.IO.Error (mkIOError, userErrorType) +import System.FilePath import qualified Text.ParserCombinators.Parsec as P +import qualified Text.ParserCombinators.Parsec.Language as L +import qualified Text.ParserCombinators.Parsec.Token as T import Text.PrettyPrint.HughesPJ import Data.FsmActions import Data.FsmActions.Error - +import Data.FsmActions.WellFormed -- | This module's internal represenation of adjacency matrices is as -- nested lists of booleans. These are only ever used as intermediate @@ -43,38 +66,86 @@ type ActionMatrix = [ActionMatrixRow] type ActionMatrixRow = [Bool] --- | Given a list of (symbol, path) pairs, compute an +-- | Load an 'Data.FsmActions.FSM' from action matrices, given a path +-- to an ActionSpec file. +loadActionMxFsm :: FilePath -> IO (FSM String) +loadActionMxFsm specPath = + do contents <- readFile specPath + let result = parseFsmActionSpec contents + case result of + Right actionSpecs -> parseFsmActionMxFiles (addDir actionSpecs) + where addDir = map (second (replaceFileName specPath)) + Left e -> throw $ FsmError (show e) specPath + +-- | Save an 'Data.FsmActions.FSM' to an ActionSpec file (whose path +-- is specified) and a set of action matrices (whose paths may be +-- optionally specified using a (label, path) association list). +saveActionMxFsm :: FSM String -> FilePath -> [(String, FilePath)] -> IO () +saveActionMxFsm fsm spath labelPaths = + do let (spec, mxs) = printFsmActionMx fsm labelPaths + writeFile spath spec + mapM_ (\(p, m) -> writeFile (combine (takeDirectory spath) p) m) mxs + + + +-- | Parse an fsmActionSpec string to a (label, ActionMatrix path) +-- association list. +parseFsmActionSpec :: String -> ReadFsmMonad [(String, FilePath)] +parseFsmActionSpec actionSpecString = + case P.parse fsmActionSpecParser "" actionSpecString of + Right actionSpecs -> return actionSpecs + Left err -> throw $ FsmError "FSM action specs parse error" (show err) + +-- | Parser for fsmActionSpec strings. +fsmActionSpecParser :: P.Parser [(String, FilePath)] +fsmActionSpecParser = P.sepEndBy1 lineParser (T.semi l) + where lineParser :: P.Parser (String, FilePath) + lineParser = do T.whiteSpace l + label <- T.stringLiteral l + mxPath <- T.stringLiteral l + return (label, mxPath) + l :: T.TokenParser st + l = T.makeTokenParser L.emptyDef { + L.commentLine = "--" + } + +-- | Given a (symbol, path) association list, compute an -- 'Data.FsmActions.FSM' whose actions are read from action matrices --- in the specified paths, associated with their corresponding +-- in the specified paths, and associated with their corresponding -- symbols. +parseFsmActionMxFiles :: (Ord sy, Show sy) => [(sy, FilePath)] -> IO (FSM sy) +parseFsmActionMxFiles xs = + do files <- readActionMxFiles xs + let result = parseFsmActionMxs files + case result of + Right fsm -> return fsm + Left e -> throw $ FsmError "ActionMatrix parse error" (show e) + where readActionMxFiles :: Ord sy => [(sy, FilePath)] -> IO [(sy, String)] + readActionMxFiles = mapM (liftMSnd readFile) + +liftMSnd :: Monad m => (a -> m b) -> (c, a) -> m (c, b) +liftMSnd f (x, y) = f y >>= \z -> return (x, z) + +-- | Given a (symbol, ActionMatrix string) association list, parse the +-- strings and construct an FSM. Includes normalisation and +-- well-formedness checks. Parse errors in individual action strings +-- result in an error here (ReadFsmMonad is in the Either monad). -- -- Note that if the same symbol appears multiple times, only one -- instance will appear in the 'Data.FsmActions.FSM'; the choice of which -- appears is not defined. -parseFsmActionMxFiles :: Ord sy => [(sy, FilePath)] -> IO (FSM sy) -parseFsmActionMxFiles xs = - liftM fromList $ mapM (liftMSnd parseActionMxFile) xs - where liftMSnd :: Monad m => (a -> m b) -> (c, a) -> m (c, b) - liftMSnd f (x, y) = f y >>= \z -> return (x, z) - --- | Read an action matrix from a specified file, and parse it into an --- 'Data.FsmActions.Action'. -parseActionMxFile :: FilePath -> IO Action -parseActionMxFile path = - do contents <- readFile path - let act = parseActionMx contents - case act of - Right a -> return a - Left e -> throwError (mkIOError userErrorType (show e) - Nothing (Just path)) +parseFsmActionMxs :: (Ord sy, Show sy) => [(sy, String)] + -> ReadFsmMonad (FSM sy) +parseFsmActionMxs xs = + liftM fromList (mapM (liftMSnd parseActionMx) xs) >>= polishFSM -- | Parse an action matrix string, and turn it into an -- 'Data.FsmActions.Action'. -parseActionMx :: String -> ReadMxMonad Action +parseActionMx :: String -> ReadFsmMonad Action parseActionMx actionString = case P.parse actionMxParser "" actionString of Right mx -> interpretActionMx mx - Left err -> throwError (MxError "Action matrix parse error" (show err)) + Left err -> throw $ FsmError "Action matrix parse error" (show err) -- | Parse an action matrix from a string. -- @@ -97,11 +168,11 @@ -- | Given an 'ActionMatrix', compute the corresponding -- 'Data.FsmActions.Action'. -interpretActionMx :: ActionMatrix -> ReadMxMonad Action +interpretActionMx :: ActionMatrix -> ReadFsmMonad Action interpretActionMx rows = if all (== length transitions) rowLengths -- check matrix is square then return $ normaliseAction $ mkAction transitions - else throwError (MxError "action matrix is not square (see row lengths)" + else throwError (FsmError "action matrix is not square (see row lengths)" (show rowLengths)) where transitions = L.map parseActionMxRow rows rowLengths = L.map length rows @@ -114,6 +185,55 @@ withIdxs ys = zip ys [0..(length ys-1)] -- | Iff the cell is set, include its index.. isSet (cell, index) = if cell then Just index else Nothing + + + +-- | Pretty-print a string FSM into an ActionSpec string and an +-- (ActionMatrix path, ActionMatrix string) association list. (The +-- paths will be interpreted relative to the ActionSpec's location.) +-- Filenames (per action label) may be specified by providing a +-- (label, path) association list; whenever a lookup in that list +-- fails, a default is computed from the label. +printFsmActionMx :: FSM String -> [(String, FilePath)] -> + (String, [(FilePath, String)]) +printFsmActionMx fsm paths = (spec, matrices) + where spec = show $ ppActionSpec $ map (\(l, p, _) -> (l, p)) actionData + matrices = map (\(_, p, m) -> (p, m)) actionData + actionData :: [(String, FilePath, String)] + actionData = fsmMap (getActionData paths) fsm + -- Given a (label, file path) association list, a label, and + -- an action, compute a triple consisting of the specified + -- label, the file path for that label's action matrix, and + -- the action matrix as a string. If label lookup fails, + -- compute a default path from the label. + getActionData pd l a = (l, mxPath, printActionMx a) + where mxPath = case L.lookup l pd of + Just x -> x + Nothing -> defaultPath l + +-- | Compute the default path for a symbol; we take the symbol, +-- replace various undesirable characters with underscores, and append +-- ".actionmx". +defaultPath :: String -> FilePath +defaultPath s = addExtension clean ".actionmx" + where -- There's got to be a nicer way to do this!? + clean = foldr ($) s (map (flip replace "_") undesirable) + -- This is slightly cock-eyed: we define a string of + -- undesirable characters, each of which will be replaced + -- with an underscore. However, the replace function we're + -- using (from the MissingH package), takes a _string_ to + -- replace, not a character, so we then turn each of those + -- characters into a single-character string. + undesirable :: [String] + undesirable = map (: []) " \t\n\f\r\'\"\\&:/" + +-- Pretty printer to ActionSpec format. Takes a (label, path) +-- association list. +ppActionSpec :: [(String, FilePath)] -> Doc +ppActionSpec = vcat . map (uncurry ppOnePair) + where ppOnePair :: String -> FilePath -> Doc + ppOnePair symbol path = quoth symbol <+> quoth path <+> semi + where quoth = doubleQuotes . text -- | Pretty-print an action in action matrix format. printActionMx :: Action -> String diff --git a/Data/FsmActions/Error.hs b/Data/FsmActions/Error.hs --- a/Data/FsmActions/Error.hs +++ b/Data/FsmActions/Error.hs @@ -7,27 +7,33 @@ -- Copyright (c) 2009 Andy Gimblett - http://www.cs.swan.ac.uk/~csandy/ -- BSD Licence (see http://www.opensource.org/licenses/bsd-license.php) +{-# LANGUAGE DeriveDataTypeable #-} + module Data.FsmActions.Error ( - MxError(..), - ReadMxMonad + FsmError(..), + ReadFsmMonad ) where +import Control.Exception import Control.Monad.Error +import Data.Typeable -- | Errors when reading matrices from strings. -data MxError = MxError { +data FsmError = FsmError { -- | Explanatory message msg :: String, -- | Offending value value :: String - } deriving (Eq) + } deriving (Eq, Typeable) -instance Error MxError where - noMsg = MxError "Matrix error" "" - strMsg s = MxError s "" +instance Exception FsmError -instance Show MxError where - show (MxError message val) = message ++ " (" ++ val ++ ")" +instance Error FsmError where + noMsg = FsmError "FSM error" "" + strMsg s = FsmError s "" --- | Error monad for reading matrices from strings. -type ReadMxMonad = Either MxError +instance Show FsmError where + show (FsmError message val) = message ++ " (" ++ val ++ ")" + +-- | Error monad for reading FSMs in. +type ReadFsmMonad = Either FsmError diff --git a/Data/FsmActions/FsmEdges.hs b/Data/FsmActions/FsmEdges.hs new file mode 100644 --- /dev/null +++ b/Data/FsmActions/FsmEdges.hs @@ -0,0 +1,110 @@ +{- | + +Serialisation/deserialisation of 'Data.FsmActions.FSM's in edge list +format. + +An 'Data.FsmActions.FSM' may be represented textually as list of +{source_state->destination_state,label} strings, each of which +represents an edge in its directed graph. (This representation is +interesting because it's used by Mathematica for graph I/O.) + +-} + +module Data.FsmActions.FsmEdges ( + -- * I/O + loadFsmEdges, + saveFsmEdges, + -- * Parsing + parseFsmEdges, + -- * Pretty-printing + printFsmEdges +) where + +import Control.Exception +import Control.Monad.Error +import qualified Data.Graph.Inductive.Graph as G +import Data.Graph.Inductive.Tree (Gr) +import Data.List +import qualified Text.ParserCombinators.Parsec as P +import qualified Text.ParserCombinators.Parsec.Language as L +import qualified Text.ParserCombinators.Parsec.Token as T +import Text.PrettyPrint.HughesPJ + +import Data.FsmActions +import Data.FsmActions.Error +import Data.FsmActions.Graph + +-- The intermediate result of parsing will be a list of edges. +data Edge = Edge Integer Integer String + deriving (Eq, Show) + +-- | Load an 'Data.FsmActions.FSM' from an FsmEdges file. +loadFsmEdges :: FilePath -> IO (FSM String) +loadFsmEdges path = + do contents <- readFile path + let result = parseFsmEdges contents + case result of + Right fsm -> return fsm + Left e -> throw $ FsmError (show e) path + +-- | Save an 'Data.FsmActions.FSM' to an FsmMatrix file. +saveFsmEdges :: FSM String -> FilePath -> IO () +saveFsmEdges fsm mxPath = do let mx = printFsmEdges fsm + writeFile mxPath mx + + + +-- | Parse an FsmEdges-formatted FSM held in a string. Includes +-- normalisation and well-formedness checks. +parseFsmEdges :: String -> ReadFsmMonad (FSM String) +parseFsmEdges fsmString = + case P.parse fsmEdgesParser "" fsmString of + Right edges -> do (fsm, _) <- (fglToFsm . edgesToFGL) edges + return fsm + Left err -> throw $ FsmError "FSM edges parse error" (show err) + +-- FsmEdges-format parser. +fsmEdgesParser :: P.Parser [Edge] +fsmEdgesParser = T.braces l $ T.commaSep l fsmEdgeParser + where fsmEdgeParser :: P.Parser Edge + fsmEdgeParser = T.braces l $ do source <- T.natural l + T.symbol l "->" + destination <- T.natural l + T.comma l + label <- T.identifier l + return $ Edge source destination label + l :: T.TokenParser st + l = T.makeTokenParser L.emptyDef + +-- Turn a list of edges into an FGL graph, inferring the node list +-- from those mentioned in the edges. +edgesToFGL :: [Edge] -> Gr () String +edgesToFGL edges = G.mkGraph gNodes gEdges + where gEdges = map fst extracted + gNodes = sort $ nub $ concatMap snd extracted + extracted = map edgeExtract edges + -- Turn an FsmEdges Edge into an FGL (LEdge, [LNodes]) pair. + edgeExtract :: Edge -> (G.LEdge String, [G.LNode ()]) + edgeExtract (Edge s' d' l) = ((s, d, l), [(s, ()), (d, ())]) + where s = fromInteger s' + d = fromInteger d' + + + +-- | Pretty-print a string FSM in FsmMatrix format. +printFsmEdges :: FSM String -> String +printFsmEdges = show . ppFsmEdges + +-- Pretty printer to FsmEdges format (building Doc not String). +ppFsmEdges :: FSM String -> Doc +ppFsmEdges fsm = ppFsmEdges' $ map tweakEdge $ G.labEdges $ fsmToFGL fsm Trim + where -- Convert fgl-format Edge to the ones used by this module. + tweakEdge :: CleanShow sy => G.LEdge sy -> Edge + tweakEdge (s, d, l) = Edge (toInteger s) (toInteger d) (cleanShow l) + ppFsmEdges' :: [Edge] -> Doc + ppFsmEdges' = braces . vcat . punctuate comma . map ppFsmEdge + ppFsmEdge :: Edge -> Doc + ppFsmEdge (Edge src dest label) = + braces $ integer src <> text "->" <> + integer dest <> comma <> + text label diff --git a/Data/FsmActions/FsmMatrix.hs b/Data/FsmActions/FsmMatrix.hs --- a/Data/FsmActions/FsmMatrix.hs +++ b/Data/FsmActions/FsmMatrix.hs @@ -15,17 +15,19 @@ -} module Data.FsmActions.FsmMatrix ( - -- * Input - parseFsmMxFile, + -- * I/O + loadFsmMx, + saveFsmMx, + -- * Parsing parseFsmMx, - -- * Output + -- * Pretty-printing printFsmMx ) where +import Control.Exception import Control.Monad.Error import Data.Char (isSpace) import qualified Data.List as L -import System.IO.Error (mkIOError, userErrorType) import qualified Text.ParserCombinators.Parsec as P import Text.PrettyPrint.HughesPJ @@ -33,36 +35,29 @@ import Data.FsmActions.Error import Data.FsmActions.WellFormed --- | Parse an FsmMatrix-formatted FSM held in a file, by reading the --- file and calling 'parseFsmString'. -parseFsmMxFile :: FilePath -> IO (FSM String) -parseFsmMxFile path = +-- | Load an 'Data.FsmActions.FSM' from an FsmMatrix file. +loadFsmMx :: FilePath -> IO (FSM String) +loadFsmMx path = do contents <- readFile path let result = parseFsmMx contents case result of Right fsm -> return fsm - Left e -> throwError (mkIOError userErrorType (show e) - Nothing (Just path)) + Left e -> throw $ FsmError (show e) path +-- | Save an 'Data.FsmActions.FSM' to an FsmMatrix file. +saveFsmMx :: FSM String -> FilePath -> IO () +saveFsmMx fsm mxPath = do let mx = printFsmMx fsm + writeFile mxPath mx + + + -- | Parse an FsmMatrix-formatted FSM held in a string. Includes -- normalisation and well-formedness checks. -parseFsmMx :: String -> ReadMxMonad (FSM String) +parseFsmMx :: String -> ReadFsmMonad (FSM String) parseFsmMx fsmString = case P.parse fsmMatrixParser "" fsmString of - Right parts -> - do fsm <- interpretFsmMx parts - case (isWellFormed fsm) of - WellFormed -> return fsm - Disconnected wccs -> - throwError (MxError "FSM disconnected" (show wccs)) - err -> throwError (MxError "FSM matrix ill-formed" (show err)) - Left err -> - throwError (MxError "FSM matrix parse error" (show err)) - --- TODO: there are well-formedness checks here, but not when reading --- in from action matrices. Generalise! Either remove the checks --- here, or factor them out into an handy "run this after input" --- function. + Right parts -> interpretFsmMx parts >>= polishFSM + Left err -> throw $ FsmError "FSM matrix parse error" (show err) -- FsmMatrix-format parser. fsmMatrixParser :: P.Parser ([String], [[[Int]]]) @@ -89,14 +84,16 @@ nonEOLSpace = P.many1 (P.satisfy (\c -> isSpace c && c /= '\n')) -- Turn some FsmMatrix-formatted data into an (normalised) FSM. -interpretFsmMx :: ([String], [[[Int]]]) -> ReadMxMonad (FSM String) +interpretFsmMx :: ([String], [[[Int]]]) -> ReadFsmMonad (FSM String) interpretFsmMx (actionNames, stateLines) = if all (== (length actionNames)) lineLengths then return $ normalise $ fromList $ zip actionNames actions - else throwError (MxError "FSM matrix ill-formed" (show lineLengths)) + else throwError (FsmError "FSM matrix ill-formed" (show lineLengths)) where actions = map mkAction $ L.transpose stateLines lineLengths = L.map length stateLines + + -- | Pretty-print a string FSM in FsmMatrix format. printFsmMx :: FSM String -> String printFsmMx = show . ppFsmMx @@ -125,4 +122,3 @@ commas [] = empty commas (x:[]) = x commas (x:xs) = x <> comma <> commas xs - diff --git a/Data/FsmActions/Graph.hs b/Data/FsmActions/Graph.hs --- a/Data/FsmActions/Graph.hs +++ b/Data/FsmActions/Graph.hs @@ -1,10 +1,10 @@ {- | -Generating and drawing graphs of FSMs. +Generating, interpreting, and drawing graphs of FSMs. Includes: - - Interface to fgl graph library + - Interface to fgl graph library for graph input/output (). - Interface to graphviz library for dot output @@ -28,27 +28,40 @@ -- * FGL graph operations. SelfLoops(..), fsmToFGL, + fglDot, -- XXX strongCCs, weakCCs, -- * Dot and GML format output. CleanShow, + cleanShow, fsmToDot, - fsmToGML + fsmToGML, + -- * Input. + fglToFsm ) where import Data.Graph.Inductive.Basic (undir) -import Data.Graph.Inductive.Graph (Graph, labEdges, mkGraph) +import Data.Graph.Inductive.Graph (Graph, labEdges, labNodes, Node, + LNode, mkGraph) import qualified Data.Graph.Inductive.PatriciaTree as P import qualified Data.Graph.Inductive.Tree as T import Data.Graph.Inductive.Query.DFS (scc) import Data.GraphViz +import Data.List (foldr, nub, sort) +import qualified Data.Map as M +import Data.Map.Utils (forceLookupM) import Text.PrettyPrint.HughesPJ -import Data.FsmActions +import Data.FsmActions hiding (mkAction) +import Data.FsmActions.Error +import Data.FsmActions.WellFormed (polishFSM) -- | When converting an 'Data.FsmActions.FSM' into a graph, do we keep -- all self-loops, or only those which are sources of nondeterminism? -data SelfLoops = Keep | Trim +data SelfLoops = -- | Keep them all + Keep + -- | Trim any which aren't nondeterminism sources. + | Trim -- | Turn an FSM into an fgl graph with labelled edges. fsmToFGL :: FSM sy -> SelfLoops -> T.Gr () sy @@ -116,6 +129,8 @@ cleanShow :: a -> String cleanShow = show -- by default, turn it to a String instance (Show a) => CleanShow a +instance CleanShow () where + cleanShow _ = "" instance CleanShow String where cleanShow = id -- don't need to do anything for a String instance CleanShow Char where @@ -125,12 +140,12 @@ -- | Turn an FSM into a 'Data.GraphViz.DotGraph', trimming any -- self-loops which aren't sources of nondeterminism. -fsmToDot :: (Ord sy, CleanShow sy) => FSM sy -> DotGraph +fsmToDot :: (Ord sy, CleanShow sy) => FSM sy -> DotGraph Int fsmToDot = fglDot . flip fsmToFGL Trim -- Turn an FGL into a DotGraph with labelled edges. -fglDot :: (Ord b, CleanShow b, Graph gr) => gr a b -> DotGraph -fglDot g = graphToDot g [] nodeFn edgeFn +fglDot :: (Ord b, CleanShow b, Graph gr) => gr a b -> DotGraph Int +fglDot g = graphToDot True g [] nodeFn edgeFn where nodeFn _ = [] edgeFn (_, _, label) = [Label $ StrLabel $ cleanShow label] @@ -160,3 +175,107 @@ text "target" <+> text (show dest), text "label" <+> doubleQuotes (text $ cleanShow label) ]) + + + +-- And now for some input. + +-- | Turn an FGL graph (interpreted as being a directed graph) into an +-- FSM. Self-loops are inserted as required. Also returns a list of +-- the graph's labelled nodes, since the labels are discarded by the +-- FSM construction. FSM states are numbered [0..] and thus may be +-- used as an index into that list of labelled nodes, in order to +-- relate FSM states back to the original graph nodes and their +-- labels. +fglToFsm :: (Graph gr, Ord sy, Show sy) => gr a sy -> + ReadFsmMonad (FSM sy, [LNode a]) +fglToFsm g = do let (nodes, actions) = graphActions g + let fsm = fromList actions + p <- polishFSM fsm + return (p, nodes) + +-- | Turn a graph into a list of its labelled nodes (indexed by +-- corresponding FSM state) and a list of (symbol, +-- 'Data.FsmActions.Action') pairs. +graphActions :: (Graph gr, Ord b) => gr a b -> ([LNode a], [(b, Action)]) +graphActions g = (nodeList, actions) + where nodeList = labNodes g + actions = mkActions destsMap nodeMap srcStates actionSymbols + srcStates = map fst nodeList + actionSymbols = symbols g + destsMap = mkDestsMap g + nodeMap = mkNodeMap g + +mkActions :: Ord sy => DestsMap sy -> NodeMap -> [Node] -> [sy] -> + [(sy, Action)] +mkActions destsMap nodeMap srcs ls = + map (mkAction destsMap nodeMap srcs) ls + +mkAction :: Ord sy => DestsMap sy -> NodeMap -> [Node] -> sy -> + (sy, Action) +mkAction destsMap nodeMap srcs l = + (l, Action $ map (mkDestSet destsMap nodeMap l) srcs) + +mkDestSet :: Ord b => DestsMap b -> NodeMap -> b -> Node -> + DestinationSet +mkDestSet destsMap nodeMap l src = + DestinationSet $ map (nodeToState nodeMap) destNodes + where destNodes = M.findWithDefault [src] (l, src) destsMap + +-- | Given a labelled directed graph, compute the list of its unique +-- labels, which will be the corresponding FSM's symbols. +symbols :: (Graph gr, Ord sy) => gr a sy -> [sy] +symbols = sort . nub . map (\(_,_,s) -> s) . labEdges + +-- | A DestsMap maps (action symbol, source graph node) pairs to +-- [destination graph node] lists, which provide a handy lookup when +-- building 'Data.FsmActions.DestinationSet's. +type DestsMap sy = M.Map (sy, Node) [Node] + +-- | Build a DestsMap from a graph. +mkDestsMap :: (Graph gr, Ord b) => gr a b -> DestsMap b +mkDestsMap = foldr insertEdge M.empty . labEdges + where insertEdge (s, d, l) = M.insertWith (++) (l, s) [d] + +-- | A NodeMap is a map from graph node numbers to FSM state numbers, +-- the inverse of the indexing produced by labNodes, ie +-- forall n . (fst (labNodes g !! n)) `M.lookup` nodeMap g == n +type NodeMap = M.Map Node State + +-- | Construct a NodeMap. +mkNodeMap :: Graph gr => gr a b -> NodeMap +mkNodeMap = M.fromList . map flipPair . zipWithIndex . map fst . labNodes + where flipPair (a,b) = (b,a) + +-- | Perform a node -> state lookup in a NodeMap; throws an exception +-- if it fails, which it shouldn't ever here. +nodeToState :: NodeMap -> Node -> State +nodeToState nodeMap node = forceLookupM err node nodeMap + where err = "Node -> State lookup failure (can't happen?)" + + + +-- Examples for hacking. + +{- +love :: T.Gr Char String +love = mkGraph nodes edges + where nodes = [(1, 'x'), (3, 'y'), (5, 'z')] + edges = [(1,3,"a"), (3,5,"a"), (5,3,"a"), + (1,1,"b"), (3,3,"b"), (5,1,"b"), + (1,1,"c"), (3,3,"c"), (5,1,"c") + ] + +mooKid :: T.Gr () String +mooKid = mkGraph (map mkNode nodes) edges + where mkNode x = (x, ()) + nodes = [0,1,2] + edges = [(0,0,"a") + ,(0,1,"a") + ,(0,2,"c") + ,(1,1,"b") + ,(1,0,"a") + ,(2,0,"c") + ] + +-} diff --git a/Data/FsmActions/Graph.hs-boot b/Data/FsmActions/Graph.hs-boot new file mode 100644 --- /dev/null +++ b/Data/FsmActions/Graph.hs-boot @@ -0,0 +1,14 @@ +-- | There's a module import cycle between Graph and WellFormed, +-- because WellFormed wants to be able to check if an FSM is +-- weakly-connected, and Graph wants to perform well-formedness checks +-- when converting a graph to an FSM. We break the cycle here, by +-- being explicit about the first case (since its the smaller of the +-- two). + +module Data.FsmActions.Graph ( + weakCCs +) where + +import Data.FsmActions + +weakCCs :: Eq sy => FSM sy -> [[State]] diff --git a/Data/FsmActions/IO.hs b/Data/FsmActions/IO.hs new file mode 100644 --- /dev/null +++ b/Data/FsmActions/IO.hs @@ -0,0 +1,120 @@ +{- | + +High-level input/output interface for finite state machines. + +This module allows one to load and save FSMs, where the format to be +used may be either explicitly specified, or guessed according to the +filename's extension. + +-} + +-- Copyright (c) 2009 Andy Gimblett - http://www.cs.swan.ac.uk/~csandy/ +-- BSD Licence (see http://www.opensource.org/licenses/bsd-license.php) + +module Data.FsmActions.IO ( + FsmIO(..), + fsmFormats, + loadFsm, + saveFsm +) where + +import Control.Exception +import Data.Char (toLower) +import Data.Either +import Data.List +import qualified Data.Map as M +import qualified Data.List as L +import Data.Maybe (mapMaybe) +import System.FilePath + +import Data.FsmActions +import Data.FsmActions.ActionMatrix +import Data.FsmActions.Error +import Data.FsmActions.FsmEdges +import Data.FsmActions.FsmMatrix + +-- | Known FSM I/O formats. +data FsmIO = + -- | ActionMatrix format: use + -- 'Data.FsmActions.ActionMatrix.loadActionMxFsm' and + -- 'Data.FsmActions.ActionMatrix.saveActionMxFsm'; filename + -- extensions: actions, actionspec, actionmxs, + -- actionmatrices, fsmactions. + FsmActionMatrices + -- | FsmEdges format: use + -- 'Data.FsmActions.FsmEdges.loadFsmEdges' and + -- 'Data.FsmActions.FsmEdges.saveFsmEdges'; filename + -- extensions: edges, fsmedges, graph, mathematica. + | FsmEdges + -- | FsmMatrix format: use + -- 'Data.FsmActions.FsmMatrix.loadFsmMx' and + -- 'Data.FsmActions.FsmMatrix.saveFsmMx'; filename + -- extensions: mx, matrix, fsmmx, fsmmatrix, fsm. + | FsmMatrix + deriving (Bounded, Enum, Eq, Ord, Show) + +-- | Mapping from 'FsmIO' formats to lists of expected filename +-- extensions for those formats. +fsmIOExts :: M.Map FsmIO [String] +fsmIOExts = M.fromList [ + (FsmActionMatrices, ["actions", "actionspec", "actionmxs", + "actionmatrices", "fsmactions", + "fsmactionmxs"]) + ,(FsmEdges, ["edges", "fsmedges", "graph", "mathematica"]) + + ,(FsmMatrix, ["mx", "matrix", "fsmmx", "fsmmatrix", "fsm"]) + ] + +-- | Given a path, return a list of all 'FsmIO' formats, with guesses +-- (according to the file extension) at the front. +fsmFormats :: FilePath -> [FsmIO] +fsmFormats path = guesses ++ ([minBound..maxBound] \\ guesses) + where guesses = seek `rLookup` fsmIOExts + (_, ext) = splitExtension path + seek = L.map toLower (tail ext) + +-- | Reverse lookup in map from keys to lists of values. +rLookup :: (Ord k, Eq v) => v -> M.Map k [v] -> [k] +rLookup val m = mapMaybe (uncurry seek) $ M.toList m + where seek key vs = if val `elem` vs then Just key else Nothing + +-- | Read an 'Data.FsmActions.FSM' from a file. If the user specifies +-- any 'FsmIO' formats, try each of those in turn; otherwise, try +-- every format known, using the filename extension to guess which to +-- try first. +-- +-- The returned value is either the resultant 'Data.FsmActions.FSM', +-- or the error message produced by trying to load it with the _first_ +-- format (so in the case of guessing formats, if the guess is wrong +-- and the file is corrupt, you might get an unhelpful error message). +loadFsm :: FilePath -> [FsmIO] -> IO (Either FsmError (FSM String)) +loadFsm p formats' = + do results <- mapM (uncurry tryLoadFsm) $ zip (repeat p) formats + let success = rights results + case success of + (fsm:_) -> return $ Right fsm + _ -> return $ Left $ head $ lefts results + where formats = if L.null formats' then fsmFormats p + else formats' + +-- | Try loading an FSM from a file with a particular format. +tryLoadFsm :: FilePath -> FsmIO -> IO (Either FsmError (FSM String)) +tryLoadFsm p f = try (case f of + FsmActionMatrices -> loadActionMxFsm p + FsmEdges -> loadFsmEdges p + FsmMatrix -> loadFsmMx p) + +-- | Save an 'Data.FsmActions.FSM' to a file. If the user specifies +-- an 'FsmIO' format, it is used; otherwise, it is guessed from the +-- filename extension (and failing that, the first guess, ie +-- 'FsmActionMatrices', is used). +saveFsm :: FSM String -> FilePath -> Maybe FsmIO -> IO () +saveFsm fsm p format' = + case format of + FsmActionMatrices -> saveActionMxFsm fsm p [] + FsmEdges -> saveFsmEdges fsm p + FsmMatrix -> saveFsmMx fsm p + where format = case format' of + Just f -> f + -- None specified: use first guess. + Nothing -> head $ fsmFormats p diff --git a/Data/FsmActions/WellFormed.hs b/Data/FsmActions/WellFormed.hs --- a/Data/FsmActions/WellFormed.hs +++ b/Data/FsmActions/WellFormed.hs @@ -10,18 +10,16 @@ module Data.FsmActions.WellFormed ( WellFormed(..), isWellFormed, + polishFSM ) where -{- --- We use a PatriciaTree because we care about speed, and it doesn't --- matter if duplicate edges are lost when checked for SCCs. -import Data.Graph.Inductive.PatriciaTree (Gr) --} +import Control.Monad.Error import qualified Data.Map as M import qualified Data.List as L import Data.FsmActions -import Data.FsmActions.Graph +import Data.FsmActions.Error +import {-# SOURCE #-} Data.FsmActions.Graph (weakCCs) -- | An 'FSM' is well-formed if all its actions are the same length, -- none of its actions contain destinations which are out of range, @@ -67,6 +65,23 @@ -- Compute the FSM's undirected strongly-connected -- components. wccs = weakCCs fsm + +-- | Given an FSM, normalise it and check it's well-formed. +-- +-- This should be called whenever an FSM is read/computed from an +-- outside source. If parsing, the right time to call this is +-- immediately after you've decided if the parse of the FSM was +-- successful or not. (In other words, here are some static checks!) +polishFSM :: (Ord sy, Show sy) => FSM sy -> ReadFsmMonad (FSM sy) +polishFSM fsm = + let norm = normalise fsm in + case (isWellFormed norm) of + WellFormed -> return norm + Disconnected wccs -> + throwError (FsmError "FSM disconnected" (show wccs)) + err -> throwError (FsmError "FSM ill-formed" (show err)) + + -- Check if every element of a list is identical. allSame :: Eq a => [a] -> Bool diff --git a/doc/fsmActions.pdf b/doc/fsmActions.pdf Binary files a/doc/fsmActions.pdf and b/doc/fsmActions.pdf differ diff --git a/fsmActions.cabal b/fsmActions.cabal --- a/fsmActions.cabal +++ b/fsmActions.cabal @@ -1,5 +1,5 @@ Name: fsmActions -Version: 0.3.0 +Version: 0.4.0 Stability: Alpha Synopsis: Finite state machines and FSM actions Description: @@ -25,12 +25,15 @@ Location: http://code.haskell.org/fsmActions Library - Build-Depends: base >= 3 && < 5, containers, fgl, graphviz - >=2999.1.0.1, mtl, parsec, pretty - Exposed-modules: Data.FsmActions, - Data.FsmActions.ActionMatrix, - Data.FsmActions.Error, - Data.FsmActions.FsmMatrix, - Data.FsmActions.Graph, - Data.FsmActions.WellFormed - ghc-options: -fwarn-tabs -Wall + Build-Depends: base >= 3 && < 5, containers, filepath, fgl, + graphviz >= 2999.6.0.0, MissingH, mtl, parsec, + pretty + Exposed-modules: Data.FsmActions, + Data.FsmActions.ActionMatrix, + Data.FsmActions.Error, + Data.FsmActions.FsmEdges, + Data.FsmActions.FsmMatrix, + Data.FsmActions.Graph, + Data.FsmActions.IO, + Data.FsmActions.WellFormed + ghc-options: -fwarn-tabs -Wall