fsmActions 0.3.0 → 0.4.0

raw patch · 11 files changed

+595/−92 lines, 11 filesdep +MissingHdep +filepathdep ~graphvizPVP ok

version bump matches the API change (PVP)

Dependencies added: MissingH, filepath

Dependency ranges changed: graphviz

API changes (from Hackage documentation)

Files

• Data/FsmActions.hs +1/−1
• Data/FsmActions/ActionMatrix.hs +147/−27
• Data/FsmActions/Error.hs +17/−11
• Data/FsmActions/FsmEdges.hs +110/−0
• Data/FsmActions/FsmMatrix.hs +24/−28
• Data/FsmActions/Graph.hs +128/−9
• Data/FsmActions/Graph.hs-boot +14/−0
• Data/FsmActions/IO.hs +120/−0
• Data/FsmActions/WellFormed.hs +21/−6
• doc/fsmActions.pdf binary
• fsmActions.cabal +13/−10

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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-

@@ -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     (<http://hackage.haskell.org/package/fgl>).    - 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")+                  ]++-}

@@ -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]]

@@ -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

@@ -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

binary file changed (143688 → 147536 bytes)

@@ -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