{- |

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.

An ActionSpecFile is a list of (symbol string, path to ActionMatrix
file) pairs.  Its syntax is as follows:

  - Symbols, and paths, should all be enclosed in double quotes (with
    the nice side-effect that spaces are thus allowed).

  - A symbol/path pair is separated by whitespace.

  - The list of symbol/path pairs is delimited by semicolons (and
    optional whitespace).  A trailing semicolon is optional.

  - Line comments, starting with -- (as in Haskell), are allowed
    anywhere whitespace is allowed.


module Data.FsmActions.ActionMatrix (
    -- * I/O
    -- * Parsing
    -- * Pretty-printing
) where

import Control.Arrow (second)
import Control.Exception
import Control.Monad.Error
import qualified Data.List as L
import Data.Maybe (fromMaybe, mapMaybe)
import Data.String.Utils
import System.FilePath
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.WellFormed

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

-- | Load an 'Data.FsmActions.FSM' from action matrices, given a path
-- to an ActionSpec file.
loadActionMxFsm :: FilePath -> IO (FSM String)
loadActionMxFsm specPath =
    do contents <- readFile specPath
       let result = parseFsmActionSpec contents
       case result of
         Right actionSpecs -> parseFsmActionMxFiles (addDir actionSpecs)
             where addDir = map (second (replaceFileName specPath))
         Left e -> throw $ FsmError (show e) specPath

-- | Save an 'Data.FsmActions.FSM' to an ActionSpec file (whose path
-- is specified) and a set of action matrices (whose paths may be
-- optionally specified using a (label, path) association list).
saveActionMxFsm :: FSM String -> FilePath -> [(String, FilePath)] -> IO ()
saveActionMxFsm fsm spath labelPaths =
    do let (spec, mxs) = printFsmActionMx fsm labelPaths
       writeFile spath spec
       mapM_ (\(p, m) -> writeFile (combine (takeDirectory spath) p) m) mxs

-- | Parse an fsmActionSpec string to a (label, ActionMatrix path)
-- association list.
parseFsmActionSpec :: String -> ReadFsmMonad [(String, FilePath)]
parseFsmActionSpec actionSpecString =
    case P.parse fsmActionSpecParser "" actionSpecString of
      Right actionSpecs -> return actionSpecs
      Left err -> throw $ FsmError "FSM action specs parse error" (show err)

-- | Parser for fsmActionSpec strings.
fsmActionSpecParser :: Parser [(String, FilePath)]
fsmActionSpecParser = P.sepEndBy1 lineParser (T.semi l)
    where lineParser :: Parser (String, FilePath)
          lineParser = do T.whiteSpace l
                          label <- T.stringLiteral l
                          mxPath <- T.stringLiteral l
                          return (label, mxPath)
          l :: T.TokenParser st
          l = T.makeTokenParser L.emptyDef {
                T.commentLine = "--"

-- | Given a (symbol, path) association list, compute an
-- 'Data.FsmActions.FSM' whose actions are read from action matrices
-- in the specified paths, and associated with their corresponding
-- symbols.
parseFsmActionMxFiles :: (Ord sy, Show sy) => [(sy, FilePath)] -> IO (FSM sy)
parseFsmActionMxFiles xs =
    do files <- readActionMxFiles xs
       let result = parseFsmActionMxs files
       case result of
         Right fsm -> return fsm
         Left e -> throw $ FsmError "ActionMatrix parse error" (show e)
    where readActionMxFiles :: Ord sy => [(sy, FilePath)] -> IO [(sy, String)]
          readActionMxFiles = mapM (liftMSnd readFile)

liftMSnd :: Monad m => (a -> m b) -> (c, a) -> m (c, b)
liftMSnd f (x, y) = f y >>= \z -> return (x, z)

-- | Given a (symbol, ActionMatrix string) association list, parse the
-- strings and construct an FSM.  Includes normalisation and
-- well-formedness checks.  Parse errors in individual action strings
-- result in an error here (ReadFsmMonad is in the Either monad).
-- 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.
parseFsmActionMxs :: (Ord sy, Show sy) => [(sy, String)]
                        -> ReadFsmMonad (FSM sy)
parseFsmActionMxs xs =
    liftM fromList (mapM (liftMSnd parseActionMx) xs) >>= polishFSM

-- | Parse an action matrix string, and turn it into an
-- 'Data.FsmActions.Action'.
parseActionMx :: String -> ReadFsmMonad Action
parseActionMx actionString =
    case P.parse actionMxParser "" actionString of
      Right mx -> interpretActionMx mx
      Left err -> throw $ FsmError "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 :: Parser ActionMatrix
actionMxParser = do rows <- parseRow `P.sepEndBy1` P.char '\n'
                    P.skipMany $ P.char '\n' -- Ignore any trailing newlines
                    return rows
    where parseRow :: Parser [Bool]
          parseRow = parseCell `P.sepBy1` P.char ','
          parseCell :: Parser Bool
          parseCell = P.choice [ P.char '0' >> return False
                               , P.char '1' >> return True]

-- | Given an 'ActionMatrix', compute the corresponding
-- 'Data.FsmActions.Action'.
interpretActionMx :: ActionMatrix -> ReadFsmMonad Action
interpretActionMx rows =
    if all (== length transitions) rowLengths -- check matrix is square
    then return $ normaliseAction $ mkAction transitions
    else throwError (FsmError "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 a string FSM into an ActionSpec string and an
-- (ActionMatrix path, ActionMatrix string) association list.  (The
-- paths will be interpreted relative to the ActionSpec's location.)
-- Filenames (per action label) may be specified by providing a
-- (label, path) association list; whenever a lookup in that list
-- fails, a default is computed from the label.
printFsmActionMx :: FSM String -> [(String, FilePath)] ->
                    (String, [(FilePath, String)])
printFsmActionMx fsm paths = (spec, matrices)
    where spec = show $ ppActionSpec $ map (\(l, p, _) -> (l, p)) actionData
          matrices = map (\(_, p, m) -> (p, m)) actionData
          actionData :: [(String, FilePath, String)]
          actionData = fsmMap (getActionData paths) fsm
          -- Given a (label, file path) association list, a label, and
          -- an action, compute a triple consisting of the specified
          -- label, the file path for that label's action matrix, and
          -- the action matrix as a string.  If label lookup fails,
          -- compute a default path from the label.
          getActionData pd l a = (l, mxPath, printActionMx a)
              where mxPath = fromMaybe (defaultPath l) (L.lookup l pd)

-- | Compute the default path for a symbol; we take the symbol,
-- replace various undesirable characters with underscores, and append
-- ".actionmx".
defaultPath :: String -> FilePath
defaultPath s = addExtension clean ".actionmx"
    where clean = foldr (`replace` "-") s undesirable
          -- This is slightly cock-eyed: we define a string of
          -- undesirable characters, each of which will be replaced
          -- with an underscore.  However, the replace function we're
          -- using (from the MissingH package), takes a _string_ to
          -- replace, not a character, so we then turn each of those
          -- characters into a single-character string.
          undesirable :: [String]
          undesirable = map (: []) " \t\n\f\r\'\"\\&:/"

-- Pretty printer to ActionSpec format.  Takes a (label, path)
-- association list.
ppActionSpec :: [(String, FilePath)] -> Doc
ppActionSpec = vcat . map (uncurry ppOnePair)
    where ppOnePair :: String -> FilePath -> Doc
          ppOnePair symbol path = quoth symbol <+> quoth path <+> semi
              where quoth = doubleQuotes . text

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