FsmEdges.hs

{- |

Serialisation/deserialisation of 'Data.FsmActions.FSM's in edge list
format.

An 'Data.FsmActions.FSM' may be represented textually as list of
{source_state->destination_state,label} strings, each of which
represents an edge in its directed graph.  (This representation is
interesting because it's used by Mathematica for graph I/O.)

-}

module Data.FsmActions.FsmEdges (
    -- * I/O
    loadFsmEdges,
    saveFsmEdges,
    -- * Parsing
    parseFsmEdges,
    -- * Pretty-printing
    printFsmEdges
) where

import Control.Exception
import qualified Data.Graph.Inductive.Graph as G
import Data.Graph.Inductive.Tree (Gr)
import Data.List
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.Graph

-- The intermediate result of parsing will be a list of edges.
data Edge = Edge Integer Integer String
            deriving (Eq, Show)

-- | Load an 'Data.FsmActions.FSM' from an FsmEdges file.
loadFsmEdges :: FilePath -> IO (FSM String)
loadFsmEdges path =
    do contents <- readFile path
       let result = parseFsmEdges contents
       case result of
         Right fsm -> return fsm
         Left e -> throw $ FsmError (show e) path

-- | Save an 'Data.FsmActions.FSM' to an FsmMatrix file.
saveFsmEdges :: FSM String -> FilePath -> IO ()
saveFsmEdges fsm mxPath = do let mx = printFsmEdges fsm
                             writeFile mxPath mx



-- | Parse an FsmEdges-formatted FSM held in a string.  Includes
-- normalisation and well-formedness checks.
parseFsmEdges :: String -> ReadFsmMonad (FSM String)
parseFsmEdges fsmString =
    case P.parse fsmEdgesParser "" fsmString of
      Right edges -> do (fsm, _) <- (fglToFsm . edgesToFGL) edges
                        return fsm
      Left err -> throw $ FsmError "FSM edges parse error" (show err)

-- FsmEdges-format parser.
fsmEdgesParser :: Parser [Edge]
fsmEdgesParser = T.braces l $ T.commaSep l fsmEdgeParser
    where fsmEdgeParser :: Parser Edge
          fsmEdgeParser = T.braces l $ do source <- T.natural l
                                          _ <- T.symbol l "->"
                                          destination <- T.natural l
                                          _ <- T.comma l
                                          label <- T.identifier l
                                          return $ Edge source destination label
          l :: T.TokenParser st
          l = T.makeTokenParser L.emptyDef

-- Turn a list of edges into an FGL graph, inferring the node list
-- from those mentioned in the edges.
edgesToFGL :: [Edge] -> Gr () String
edgesToFGL edges = G.mkGraph gNodes gEdges
    where gEdges = map fst extracted
          gNodes = sort $ nub $ concatMap snd extracted
          extracted = map edgeExtract edges
          -- Turn an FsmEdges Edge into an FGL (LEdge, [LNodes]) pair.
          edgeExtract :: Edge -> (G.LEdge String, [G.LNode ()])
          edgeExtract (Edge s' d' l) = ((s, d, l), [(s, ()), (d, ())])
              where s = fromInteger s'
                    d = fromInteger d'



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

-- Pretty printer to FsmEdges format (building Doc not String).
ppFsmEdges :: FSM String -> Doc
ppFsmEdges fsm = ppFsmEdges' $ map tweakEdge $ G.labEdges $ fsmToFGL fsm Trim
    where -- Convert fgl-format Edge to the ones used by this module.
          tweakEdge :: CleanShow sy => G.LEdge sy -> Edge
          tweakEdge (s, d, l) = Edge (toInteger s) (toInteger d) (cleanShow l)
          ppFsmEdges' :: [Edge] -> Doc
          ppFsmEdges' = braces . vcat . punctuate comma . map ppFsmEdge
          ppFsmEdge :: Edge -> Doc
          ppFsmEdge (Edge src dest label) =
              braces $ integer src <> text "->" <>
                       integer dest <> comma <>
                       text label