module Data.FsmActions.FsmMatrix
(parseFsmFile,
parseFsmString,
printFsmMatrix,
)
where
import Control.Monad.Error
import Data.Char (isSpace)
import qualified Data.List as L
import qualified Data.Map as M
import System.IO.Error (mkIOError, userErrorType)
import qualified Text.ParserCombinators.Parsec as P
import Text.PrettyPrint.HughesPJ
import Data.FsmActions
import Data.FsmActions.Error
parseFsmFile :: FilePath -> IO (FSM String)
parseFsmFile path =
do contents <- readFile path
let result = parseFsmString contents
case result of
Right fsm -> return fsm
Left e -> throwError (mkIOError userErrorType (show e)
Nothing (Just path))
parseFsmString :: String -> ReadMxMonad (FSM String)
parseFsmString fsmString =
case P.parse fsmParser "" fsmString of
Right parts ->
do fsm <- interpretFsm parts
case (isWellFormed fsm) of
WellFormed _ -> return fsm
err -> throwError (MxError "Fsm matrix ill-formed" (show err))
Left err ->
throwError (MxError "Fsm matrix parse error" (show err))
fsmParser :: P.Parser ([String], [[[Int]]])
fsmParser = do actions <- actionName `P.sepEndBy` nonEOLSpace
P.char '\n'
transitionRows <- transitionRow `P.sepEndBy` P.char '\n'
P.many (P.satisfy isSpace)
P.eof
return (actions, transitionRows)
where
actionName :: P.Parser String
actionName = P.many1 (P.satisfy (\c -> not $ isSpace c))
transitionRow :: P.Parser [[Int]]
transitionRow = transition `P.sepEndBy1` nonEOLSpace
transition :: P.Parser [Int]
transition = state `P.sepBy1` P.char ','
state :: P.Parser Int
state = P.many1 P.digit >>= (\c -> return $ read c)
nonEOLSpace :: P.Parser String
nonEOLSpace = P.many1 (P.satisfy (\c -> isSpace c && c /= '\n'))
interpretFsm :: ([String], [[[Int]]]) -> ReadMxMonad (FSM String)
interpretFsm (actionNames, stateLines) =
case (all (== (length actionNames)) lineLengths) of
True -> return $ normalise $ FSM $ M.fromList $ zip actionNames actions
False -> throwError (MxError "FSM matrix ill-formed" (show lineLengths))
where actions = map mkAction $ L.transpose stateLines
lineLengths = L.map length stateLines
printFsmMatrix :: FSM String -> String
printFsmMatrix = show . ppFsmMatrix
ppFsmMatrix :: FSM String -> Doc
ppFsmMatrix fsm = actionRow $$ transitionRows
where
actionRow :: Doc
actionRow = hsep $ map (text . fst) asList
transitionRows :: Doc
transitionRows = vcat $ map transitionRow transitions
transitionRow :: [DestinationSet] -> Doc
transitionRow = hsep . map transition
transition :: DestinationSet -> Doc
transition = commas . map int . destinations
transitions :: [[DestinationSet]]
transitions = L.transpose $ map (destinationSets . snd) asList
asList :: [(String, Action)]
asList = M.toList $ unFSM fsm
commas :: [Doc] -> Doc
commas [] = empty
commas (x:[]) = x
commas (x:xs) = x <> comma <> commas xs