module Data.FsmActions.FsmEdges (
loadFsmEdges,
saveFsmEdges,
parseFsmEdges,
printFsmEdges
) where
import Control.Exception
import Control.Monad.Error
import qualified Data.Graph.Inductive.Graph as G
import Data.Graph.Inductive.Tree (Gr)
import Data.List
import qualified Text.ParserCombinators.Parsec as P
import qualified Text.ParserCombinators.Parsec.Language as L
import qualified Text.ParserCombinators.Parsec.Token as T
import Text.PrettyPrint.HughesPJ
import Data.FsmActions
import Data.FsmActions.Error
import Data.FsmActions.Graph
data Edge = Edge Integer Integer String
deriving (Eq, Show)
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
saveFsmEdges :: FSM String -> FilePath -> IO ()
saveFsmEdges fsm mxPath = do let mx = printFsmEdges fsm
writeFile mxPath mx
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)
fsmEdgesParser :: P.Parser [Edge]
fsmEdgesParser = T.braces l $ T.commaSep l fsmEdgeParser
where fsmEdgeParser :: P.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
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
edgeExtract :: Edge -> (G.LEdge String, [G.LNode ()])
edgeExtract (Edge s' d' l) = ((s, d, l), [(s, ()), (d, ())])
where s = fromInteger s'
d = fromInteger d'
printFsmEdges :: FSM String -> String
printFsmEdges = show . ppFsmEdges
ppFsmEdges :: FSM String -> Doc
ppFsmEdges fsm = ppFsmEdges' $ map tweakEdge $ G.labEdges $ fsmToFGL fsm Trim
where
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