ActionMatrix.hs

{- |

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.

-}

module Data.FsmActions.ActionMatrix (
    -- * Input
    parseFsmActionMxFiles,
    parseActionMxFile,
    parseActionMx,
    -- * Output
    printActionMx
) where

import Control.Monad.Error
import qualified Data.List as L
import Data.Maybe (mapMaybe)
import System.IO.Error (mkIOError, userErrorType)
import qualified Text.ParserCombinators.Parsec as P
import Text.PrettyPrint.HughesPJ

import Data.FsmActions
import Data.FsmActions.Error


-- | 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]

-- | Given a list of (symbol, path) pairs, compute an
-- 'Data.FsmActions.FSM' whose actions are read from action matrices
-- in the specified paths, associated with their corresponding
-- symbols.
--
-- 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.
parseFsmActionMxFiles :: Ord sy => [(sy, FilePath)] -> IO (FSM sy)
parseFsmActionMxFiles xs =
    liftM fromList $ mapM (liftMSnd parseActionMxFile) xs
        where liftMSnd :: Monad m => (a -> m b) -> (c, a) -> m (c, b)
              liftMSnd f (x, y) = f y >>= \z -> return (x, z)

-- | Read an action matrix from a specified file, and parse it into an
-- 'Data.FsmActions.Action'.
parseActionMxFile :: FilePath -> IO Action
parseActionMxFile path =
    do contents <- readFile path
       let act = parseActionMx contents
       case act of
         Right a -> return a
         Left e -> throwError (mkIOError userErrorType (show e)
                                         Nothing (Just path))

-- | Parse an action matrix string, and turn it into an
-- 'Data.FsmActions.Action'.
parseActionMx :: String -> ReadMxMonad Action
parseActionMx actionString =
    case P.parse actionMxParser "" actionString of
      Right mx -> interpretActionMx mx
      Left err -> throwError (MxError "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 -> ReadMxMonad Action
interpretActionMx rows =
    if all (== length transitions) rowLengths -- check matrix is square
    then return $ normaliseAction $ mkAction transitions
    else throwError (MxError "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 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