module Data.FsmActions.FsmMatrix (
loadFsmMx,
saveFsmMx,
parseFsmMx,
printFsmMx
) where
import Control.Exception
import Control.Monad.Error
import Data.Char (isSpace)
import qualified Data.List as L
import qualified Text.Parsec as P
import Text.Parsec.String
import Text.PrettyPrint.HughesPJ
import Data.FsmActions
import Data.FsmActions.Error
import Data.FsmActions.WellFormed
loadFsmMx :: FilePath -> IO (FSM String)
loadFsmMx path =
do contents <- readFile path
let result = parseFsmMx contents
case result of
Right fsm -> return fsm
Left e -> throw $ FsmError (show e) path
saveFsmMx :: FSM String -> FilePath -> IO ()
saveFsmMx fsm mxPath = do let mx = printFsmMx fsm
writeFile mxPath mx
parseFsmMx :: String -> ReadFsmMonad (FSM String)
parseFsmMx fsmString =
case P.parse fsmMatrixParser "" fsmString of
Right parts -> interpretFsmMx parts >>= polishFSM
Left err -> throw $ FsmError "FSM matrix parse error" (show err)
fsmMatrixParser :: Parser ([String], [[[Int]]])
fsmMatrixParser = 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 :: Parser String
actionName = P.many1 (P.satisfy (not . isSpace))
transitionRow :: Parser [[Int]]
transitionRow = transition `P.sepEndBy1` nonEOLSpace
transition :: Parser [Int]
transition = state `P.sepBy1` P.char ','
state :: Parser Int
state = liftM read (P.many1 P.digit)
nonEOLSpace :: Parser String
nonEOLSpace = P.many1 (P.satisfy (\c -> isSpace c && c /= '\n'))
interpretFsmMx :: ([String], [[[Int]]]) -> ReadFsmMonad (FSM String)
interpretFsmMx (actionNames, stateLines) =
if all (== length actionNames) lineLengths
then return $ normalise $ fromList $ zip actionNames actions
else throwError (FsmError "FSM matrix ill-formed" (show lineLengths))
where actions = map mkAction $ L.transpose stateLines
lineLengths = L.map length stateLines
printFsmMx :: FSM String -> String
printFsmMx = show . ppFsmMx
ppFsmMx :: FSM String -> Doc
ppFsmMx fsm = actionRow $$ transitionRows
where
actionRow :: Doc
actionRow = hsep $ map (text . fst) $ toList fsm
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) $ toList fsm
commas :: [Doc] -> Doc
commas [] = empty
commas (x:[]) = x
commas (x:xs) = x <> comma <> commas xs