{-# LANGUAGE CPP #-}
module MMSyn4 (getFormat,process2)
where
#ifdef __GLASGOW_HASKELL__
#if __GLASGOW_HASKELL__>=710
/* code that applies only to GHC 7.10.* and higher versions */
import GHC.Base (mconcat)
#endif
#endif
import Data.List (nub)
import System.Info (os)
import System.CPUTime (getCPUTime)
import System.Process (callCommand)
import CaseBi (getBFst')
import qualified Data.Vector as V
import EndOfExe (showE)
import Data.Maybe (isJust,fromJust)
#ifdef __GLASGOW_HASKELL__
#if __GLASGOW_HASKELL__==708
/* code that applies only to GHC 7.8.* */
mconcat = concat
#endif
#endif
isSep :: Char -> Bool
isSep = (== ':')
isWindows :: Bool
isWindows = take 5 os == "mingw"
divideString :: (Char -> Bool) -> String -> [String]
divideString p xs
| null xs = []
| otherwise = let (zs,ys) = break p xs in zs:(if null ys then [""] else divideString p (drop 1 ys))
isEscapeChar :: Char -> Bool
isEscapeChar x = x == '\n' || x == '\r'
dropEmptyLines :: [String] -> [String]
dropEmptyLines [] = []
dropEmptyLines (ys:yss)
| let ts = dropWhile isSep ys in all isEscapeChar ts || null ts = dropEmptyLines yss
| otherwise = ys:dropEmptyLines yss
cells :: String -> V.Vector [String]
cells = V.map (divideString isSep) . V.fromList . dropEmptyLines . map (\rs -> if drop (length rs - 1) rs == "\r" then init rs else rs) . lines
processCells :: String -> V.Vector [String] -> String
processCells xs v = makeRecordGv xs . convertElemsToStringGv . filterNeeded . changeNeededCells $ v
processCellsG :: String -> String -> String
processCellsG xs = processCells xs . cells
changeNeededCells :: V.Vector [String] -> V.Vector [String]
changeNeededCells v = V.generate (V.length v) (\i -> changeLine i v)
changeLine :: Int -> V.Vector [String] -> [String]
changeLine i v =
let n = length . takeWhile null . V.unsafeIndex v $ i
xs = parentCellContents n i v in if null xs then drop n . V.unsafeIndex v $ i else xs:(drop n . V.unsafeIndex v $ i)
parentCellContents :: Int -> Int -> V.Vector [String] -> String
parentCellContents n i v
| n == 0 || i == 0 = []
| otherwise = V.unsafeLast . V.filter (not . null) . (\v1 -> V.unsafeSlice 0 i v1) . V.map (!! (n - 1)) $ v
filterNeeded :: V.Vector [String] -> V.Vector [String]
filterNeeded = V.map (takeWhile (not . null))
convertElemsToStringGv :: V.Vector [String] -> V.Vector String
convertElemsToStringGv v = (V.map convertLineToStrGv v) V.++ (findAndMakeFilledWithClr v)
convertLineToStrGv :: [String] -> String
convertLineToStrGv xss = "\"" ++ (let ys = concatMap (++"\"->\"") xss in take (length ys - 3) ys) ++ endOfLineGv
endOfLineGv :: String
endOfLineGv | isWindows = "\r\n"
| otherwise = "\n"
findAndMakeFilledWithClr :: V.Vector [String] -> V.Vector String
findAndMakeFilledWithClr =
V.singleton . concatMap (('\"':) . (++ "\" [style=filled, fillcolor=\"#ffffba\"];" ++ endOfLineGv)) . nub . mconcat . V.toList . V.map lineWithAtSign
lineWithAtSign :: [String] -> [String]
lineWithAtSign = filter beginsWithAtSign
beginsWithAtSign :: String -> Bool
beginsWithAtSign xs = if take 1 xs == "@" then True else take 2 xs == "\"@"
makeRecordGv :: String -> V.Vector String -> String
makeRecordGv xs v = mconcat ["strict digraph 1 {", endOfLineGv, "overlap=false", endOfLineGv, "splines=",
getBFst' ("true", V.fromList [("0", "false"), ("1", "true"), ("2", "ortho"), ("3", "polyline")]) xs, endOfLineGv,
mconcat . V.toList $ v, "}", endOfLineGv]
process2 :: String -> String -> String -> String -> String -> String -> IO ()
process2 text xxs yys bnames splines remAts
| length text > 0 = do
ts <- getCPUTime
[bnames,splines] <- proc2Params2 bnames splines
if remAts == "y"
then do
let ys = filter (/='@') . processCellsG splines $ text in writeFile (show ts ++ "." ++ bnames ++ ".gv") ys
putStrLn "The visualization will be created without the at-sign."
processFile 'n' ts bnames xxs yys
else do
let ys = processCellsG splines text in writeFile ("at." ++ show ts ++ "." ++ bnames ++ ".gv") ys
putStrLn "The visualization will be created with the at-sign preserved."
processFile 'a' ts bnames xxs yys
| otherwise = error "Empty text to be processed! "
procCtrl :: Int -> IO String
procCtrl 1 = putStrLn "Please, input the basic name of the visualization file!" >> getLine
procCtrl 2 = do
putStrLn "Please, specify the splines mode for GraphViz (see the documentation for GraphViz)"
putStrLn "0 -- for \"splines=false\""
putStrLn "1 -- for \"splines=true\""
putStrLn "2 -- for \"splines=ortho\""
putStrLn "3 -- for \"splines=polyline\""
putStrLn "The default one is \"splines=true\""
getLine
procCtrl _ = putStrLn "Would you like to remove all \'@\' signs from the visualization file?" >> getLine
processFile :: Char -> Integer -> String -> String -> String -> IO ()
processFile w t zs xxs yys = do
if all (isJust . showE) ["fdp","twopi","circo","neato","sfdp","dot","patchwork","osage"]
then processFile1 w t zs xxs yys
else error "MMSyn4.processFile: Please, install the GraphViz so that its executables are in the directories mentioned in the variable PATH!"
processFile1 :: Char -> Integer -> String -> String -> String -> IO ()
processFile1 w t zs xxs yys = do
[vs,spec] <- proc2Params xxs yys
let u = take 1 vs
if null u || u == "\n" || u == "\x0000"
then error "MMSyn4.processFile1: Please, specify the needed character."
else do
let temp = getBFst' (fromJust (showE "sfdp"), V.fromList (map (\(x, y) -> (x, fromJust y)) [("c", showE "circo"), ("d", showE "dot"),
("f", showE "fdp"), ("n", showE "neato"), ("o",showE "osage"), ("p", showE "patchwork"), ("s", showE "sfdp"), ("t", showE "twopi")]))
q = getFormat spec
callCommand $ temp u ++ (if w == 'n' then " -T" ++ q ++ " " else " -T" ++ q ++ " at.") ++ show t ++ "." ++ zs ++ ".gv -O "
proc2Params :: String -> String -> IO [String]
proc2Params xxs yys
| null xxs = if null yys then mapM getFormat1 [1,2] else do { vs <- getFormat1 1 ; return [vs,yys] }
| null yys = do { spec <- getFormat1 2 ; return [xxs,spec] }
| otherwise = return [xxs,yys]
specFormatFile :: IO String
specFormatFile = do
putStrLn "Please, specify the GraphViz output format for the file: "
mapM_ printFormF ["do", "xd", "ps", "pd", "sv", "sz", "fi", "pn", "gi", "jp", "je", "js", "im", "cm"]
putStrLn "otherwise there will be used the default -Tsvg"
getLine
proc2Params2 :: String -> String -> IO [String]
proc2Params2 bnames splines
| null bnames = if null splines then mapM procCtrl [1,2] else do { bnames <- procCtrl 1 ; return [bnames,splines] }
| null splines = do { splines <- procCtrl 2 ; return [bnames,splines] }
| otherwise = return [bnames,splines]
getFormat1 :: Int -> IO String
getFormat1 1 = do
putStrLn "Please, specify the GraphViz command: "
mapM_ printGraphFilter ["d","f","t","c","n","s","p","o"]
putStrLn "otherwise there will be used the default sfdp"
getLine
getFormat1 _ = specFormatFile
getFormat :: String -> String
getFormat = getBFst' ("svg",V.fromList [("cm", "cmapx"),("do", "dot"),("fi", "fig"),("gi", "gif"),("im", "imap"),
("je", "jpeg"),("jp", "jpg"),("js", "json"),("pd", "pdf"),("pn", "png"),("ps", "ps"),("sv", "svg"),("sz", "svgz"),("xd", "xdot")])
printFormF :: String -> IO ()
printFormF xs = putStrLn $ show xs ++ " -- for -T" ++ getBFst' ("svg",V.fromList [("cm", "cmapx"),("do", "dot"),("fi", "fig"),("gi", "gif"),("im", "imap"),
("je", "jpeg"),("jp", "jpg"),("js", "json"),("pd", "pdf"),("pn", "png"),("ps", "ps"),("sv", "svg"),("sz", "svgz"),("xd", "xdot")]) xs ++ "\""
printGraphFilter :: String -> IO ()
printGraphFilter xs = putStrLn $ show (take 1 xs) ++ " -- for " ++ getBFst' ("sfdp", V.fromList [("c", "circo"), ("d", "dot"), ("f", "fdp"),
("n", "neato"), ("o", "osage"), ("p", "patchwork"), ("s", "sfdp"), ("t", "twopi")]) (take 1 xs)