module Data.FsmActions.ActionMatrix (
loadActionMxFsm,
saveActionMxFsm,
parseFsmActionMxFiles,
parseFsmActionMxs,
parseActionMx,
printFsmActionMx,
printActionMx
) where
import Control.Arrow (second)
import Control.Exception
import Control.Monad.Error
import qualified Data.List as L
import Data.Maybe (fromMaybe, mapMaybe)
import Data.String.Utils
import System.FilePath
import qualified Text.Parsec as P
import qualified Text.Parsec.Language as L
import Text.Parsec.String
import qualified Text.Parsec.Token as T
import Text.PrettyPrint.HughesPJ
import Data.FsmActions
import Data.FsmActions.Error
import Data.FsmActions.WellFormed
type ActionMatrix = [ActionMatrixRow]
type ActionMatrixRow = [Bool]
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
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
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)
fsmActionSpecParser :: Parser [(String, FilePath)]
fsmActionSpecParser = P.sepEndBy1 lineParser (T.semi l)
where lineParser :: 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 {
T.commentLine = "--"
}
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)
parseFsmActionMxs :: (Ord sy, Show sy) => [(sy, String)]
-> ReadFsmMonad (FSM sy)
parseFsmActionMxs xs =
liftM fromList (mapM (liftMSnd parseActionMx) xs) >>= polishFSM
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)
actionMxParser :: Parser ActionMatrix
actionMxParser = do rows <- parseRow `P.sepEndBy1` P.char '\n'
P.skipMany $ P.char '\n'
P.eof
return rows
where parseRow :: Parser [Bool]
parseRow = parseCell `P.sepBy1` P.char ','
parseCell :: Parser Bool
parseCell = P.choice [ P.char '0' >> return False
, P.char '1' >> return True]
interpretActionMx :: ActionMatrix -> ReadFsmMonad Action
interpretActionMx rows =
if all (== length transitions) rowLengths
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
parseActionMxRow :: ActionMatrixRow -> [Int]
parseActionMxRow xs = mapMaybe isSet (withIdxs xs)
where
withIdxs ys = zip ys [0..(length ys1)]
isSet (cell, index) = if cell then Just index else Nothing
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
getActionData pd l a = (l, mxPath, printActionMx a)
where mxPath = fromMaybe (defaultPath l) (L.lookup l pd)
defaultPath :: String -> FilePath
defaultPath s = addExtension clean ".actionmx"
where clean = foldr (`replace` "-") s undesirable
undesirable :: [String]
undesirable = map (: []) " \t\n\f\r\'\"\\&:/"
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
printActionMx :: Action -> String
printActionMx = show . ppActionMx
ppActionMx :: Action -> Doc
ppActionMx (Action dSets) = vcat $ map mkRow dSets
where
mkRow :: DestinationSet -> Doc
mkRow (DestinationSet ds) = commas $ map (isCell ds) stateList
stateList :: [State]
stateList = [0..length dSets1]
isCell :: [State] -> State -> Doc
isCell dests src = if src `elem` dests then char '1' else char '0'
commas :: [Doc] -> Doc
commas [] = empty
commas (x:[]) = x
commas (x:xs) = x <> comma <> commas xs