FsmMatrix.hs

{- |

Serialisation/deserialisation of 'Data.FsmActions.FSM's as FSM transition
matrices.

A 'Data.FsmActions.FSM' may be represented as an transition matrix whose
rows correspond to states of the FSM, and whose columns correspond to
its possible actions (labels on its transitions).  A given cell then
represents the transition(s) from some (row) state under some (column)
action, and contains a comma-separated list of integers: the row
numbers of the destination states.  (Of course, for a deterministic
action, there's just one, and no comma.)  Rows are numbered from 0 and
increment strictly.

-}

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

-- | Parse an FsmMatrix-formatted FSM held in a file, by reading the
-- file and calling 'parseFsmString'.
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))

-- | Parse an FsmMatrix-formatted FSM held in a string.  Includes
-- normalisation and well-formedness checks.
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))

-- FsmMatrix-format parser.
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) -- Parse trailing whitespace.
               P.eof
               return (actions, transitionRows)
    where -- An action name is a string of non-whitespace characters.
          actionName :: P.Parser String
          actionName = P.many1 (P.satisfy (\c -> not $ isSpace c))
          -- A row of transitions is a space-separated line of transitions.
          transitionRow :: P.Parser [[Int]]
          transitionRow = transition `P.sepEndBy1` nonEOLSpace
          -- A transition is a comma-separated list of states (no spaces).
          transition :: P.Parser [Int]
          transition = state `P.sepBy1` P.char ','
          -- A state is a natural number.
          state :: P.Parser Int
          state = P.many1 P.digit >>= (\c -> return $ read c)
          -- Parse whitespace that isn't an end of line.
          nonEOLSpace :: P.Parser String
          nonEOLSpace = P.many1 (P.satisfy (\c -> isSpace c && c /= '\n'))

-- Turn some  FsmMatrix-formatted data into an (normalised) FSM.
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

-- | Pretty-print a string FSM in FsmMatrix format.
printFsmMatrix :: FSM String -> String
printFsmMatrix = show . ppFsmMatrix

-- Pretty printer to FsmMatrix format (building Doc not String).
ppFsmMatrix :: FSM String -> Doc
ppFsmMatrix fsm = actionRow $$ transitionRows
    where -- Space-separated list of action names.
          actionRow :: Doc
          actionRow = hsep $ map (text . fst) asList
          -- Newline-separated list of transition rows.
          transitionRows :: Doc
          transitionRows = vcat $ map transitionRow transitions
          -- Space-separated list of transitions.
          transitionRow :: [DestinationSet] -> Doc
          transitionRow = hsep . map transition
          -- Comma-separated list of state numbers.
          transition :: DestinationSet -> Doc
          transition = commas . map int . destinations
          -- Extract transitions from FSM.
          transitions :: [[DestinationSet]]
          transitions = L.transpose $ map (destinationSets . snd) asList
          asList :: [(String, Action)]
          asList = M.toList $ unFSM fsm
          -- Separate a list of Docs with commas
          commas :: [Doc] -> Doc
          commas [] = empty
          commas (x:[]) = x
          commas (x:xs) = x <> comma <> commas xs