{- | Serialisation/deserialisation of 'Data.FsmActions.FSM's and 'Data.FsmActions.Action's as binary adjacency matrices. An 'Data.FsmActions.Action' may be represented as an adjacency matrix of 0s and 1s. The rows and columns of the matrix correspond to states of an 'Data.FsmActions.FSM': a 1 in a cell indicates that the 'Data.FsmActions.Action' causes a transition from the \'row\' state to the \'column\' state. If any of the rows in the matrix contain more 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 ( -- * I/O loadActionMxFsm, saveActionMxFsm, -- * Parsing parseFsmActionMxFiles, parseFsmActionMxs, parseActionMx, -- * 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.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 -- data structures, and should not be generated or manipulated -- directly. If you want to work with actions, use the Core -- 'Data.FsmActions.Action' type. If you want serialised matrices for -- storage or transmission, convert them to strings of 0s and 1s using -- the functions in this module. type ActionMatrix = [ActionMatrixRow] type ActionMatrixRow = [Bool] -- | 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, 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. 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 -> ReadFsmMonad Action parseActionMx actionString = case P.parse actionMxParser "" actionString of Right mx -> interpretActionMx mx Left err -> throw $ FsmError "Action matrix parse error" (show err) -- | Parse an action matrix from a string. -- -- The string being parsed should contain newline-separated rows, -- where each row contains comma-separated cells, where each cell is a -- 0 or a 1. Trailing newlines are ignored. actionMxParser :: P.Parser ActionMatrix actionMxParser = do rows <- parseRow `P.sepEndBy1` P.char '\n' P.skipMany $ P.char '\n' -- Ignore any trailing newlines P.eof return rows where parseRow :: P.Parser [Bool] parseRow = parseCell `P.sepBy1` P.char ',' parseCell :: P.Parser Bool parseCell = P.choice [ do P.char '0' return False , do P.char '1' return True ] -- | Given an 'ActionMatrix', compute the corresponding -- 'Data.FsmActions.Action'. interpretActionMx :: ActionMatrix -> ReadFsmMonad Action interpretActionMx rows = if all (== length transitions) rowLengths -- check matrix is square then return $ normaliseAction $ mkAction transitions else throwError (FsmError "action matrix is not square (see row lengths)" (show rowLengths)) where transitions = L.map parseActionMxRow rows rowLengths = L.map length rows -- | Given an 'ActionMatrixRow', compute the list of indices of cells -- in the row which are set (i.e. which represent transitions). parseActionMxRow :: ActionMatrixRow -> [Int] parseActionMxRow xs = mapMaybe isSet (withIdxs xs) where -- | Zip the cells of a list together with their indices. 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 printActionMx = show . ppActionMx -- Pretty printer to action matrix format. ppActionMx :: Action -> Doc ppActionMx (Action dSets) = vcat $ map mkRow dSets where -- Space-separated list of cells mkRow :: DestinationSet -> Doc mkRow (DestinationSet ds) = commas $ map (isCell ds) stateList -- List of states to iterate over stateList :: [State] stateList = [0..length dSets-1] -- Check if a certain cell should be set or not isCell :: [State] -> State -> Doc isCell dests src = if src `elem` dests then char '1' else char '0' -- Separate a list of Docs with commas commas :: [Doc] -> Doc commas [] = empty commas (x:[]) = x commas (x:xs) = x <> comma <> commas xs