module GLM.Dot where
import GLM.Parser
import qualified GLM.Nesting as N
import Data.Maybe
import System.Environment
import System.Exit
import System.IO
import Data.Digest.Pure.MD5
import Data.List
import Data.String.Interpolate
import qualified Data.ByteString.Lazy.Char8 as BS
data Options = Options { edges :: Bool
, flatten :: Bool } deriving (Eq, Show)
def :: Options
def = Options { edges = False
, flatten = False }
str5 :: String -> String
str5 = take 9 . show . md5 . BS.pack
main :: IO ()
main = getArgs >>= start def
start :: Options -> [String] -> IO ()
start _ ["-h" ] = help
start _ ["--help" ] = help
start o ("-e" : args) = start (o {edges = True}) args
start o ("--edges" : args) = start (o {edges = True}) args
start o ("-f" : args) = start (o {flatten = True}) args
start o ("--flatten": args) = start (o {flatten = True}) args
start o args = go args >>= mapM_ (outputResult o)
outputResult :: Options -> ParseResult -> IO ()
outputResult _ (Left issue) = putStrLn "Got an error:" >> spew issue >> exitFailure
outputResult opts (Right results) = putStrLn [i|digraph {#{unl $ concatMap graph (filter crit ung)}}|]
where
unl s = "\n" ++ unlines (map ("\t" ++) s)
ung = if (flatten opts) then N.flatten results else results
rt = concatMap refs ung
crit = criteria (edges opts) rt
spew :: Show a => a -> IO ()
spew = hPutStrLn stderr . show
criteria :: Bool -> [String] -> Entry -> Bool
criteria False _ _ = True
criteria True l e = isJust $ find (== name e) l
refs :: Entry -> [String]
refs e@(Entry _ p) = fromMaybe [] $ do
f <- lookup "from" c
t <- lookup "to" c
return [name e, f, t]
where
c = catProps p
help :: IO ()
help = putStrLn "Usage: glm2dot [-h|--help] [-e|--edges] [-f|--flatten] [FILE]*"
go :: [String] -> IO [ParseResult]
go xs@(_:_) = mapM processFile xs
go [] = (return . glmParser "<STDIN>") `fmap` getContents
processFile :: String -> IO ParseResult
processFile f = glmParser f `fmap` readFile f
chash :: Entry -> String
chash = (++ "ef") . take 4 . str5 . (!! 1) . unSelector
graph :: Entry -> [String]
graph e@(Entry ("object":_:_) _) = fromMaybe [ [i|"#{nhash e}" [label="#{name e}", fillcolor="##{chash e}", style=filled];|] ] (edge e)
graph e@(Entry s _) = [ [i|// Missed entry #{s} #{name e}|] ]
edge :: Entry -> Maybe [String]
edge e@(Entry _ p) = do
f <- lookup "from" c
t <- lookup "to" c
return [[i|"#{str5 f}" -> "#{str5 t}" [label="#{name e}"]; // #{f} -> #{t}|]]
where
c = catProps p
nhash :: Entry -> String
nhash = str5 . name
name :: Entry -> String
name (Entry (_:s:_) p) = maybe s noquote (lookup "name" c) where c = catProps p
name _ = "noname"
noquote :: String -> String
noquote = filter (/= '\'')