{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Erd.Config
( Config(..)
, configIO
, defaultConfig
, defaultConfigFile
)
where
import Control.Exception (tryJust)
import Control.Monad (guard)
import qualified Data.ByteString.Char8 as B
import Data.Char (isSpace)
import qualified Data.GraphViz.Attributes.Complete as A
import qualified Data.GraphViz.Commands as G
import Data.List (dropWhileEnd, intercalate, intersperse, concat)
import qualified Data.Map as M
import Data.Maybe (isNothing)
import Data.Yaml (FromJSON (..), (.:))
import qualified Data.Yaml as Y
import qualified System.Console.GetOpt as O
import System.Directory (getHomeDirectory)
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.FilePath ((</>))
import System.IO (Handle, IOMode (..),
openFile, stderr, stdin,
stdout)
import System.IO.Error (isDoesNotExistError)
import Text.Printf (HPrintfType, hPrintf,
printf)
import Text.RawString.QQ
data Config =
Config { cin :: (String, Handle)
, cout :: (String, Handle)
, outfmt :: Maybe G.GraphvizOutput
, edgeType :: Maybe A.EdgeType
, configFile :: Maybe FilePath
}
data ConfigFile = ConfigFile
{ cFmtOut :: String
, cEdgeType :: String
} deriving Show
instance FromJSON ConfigFile where
parseJSON (Y.Object v) =
ConfigFile <$>
v .: "output-format" <*>
v .: "edge-style"
parseJSON _ = fail "Incorrect configuration file."
defaultConfig :: Config
defaultConfig =
Config { cin = ("<stdin>", stdin)
, cout = ("<stdout>", stdout)
, outfmt = Nothing
, edgeType = Just A.SplineEdges
, configFile = Nothing
}
defaultConfigFile :: B.ByteString
defaultConfigFile = B.unlines
[[r|# Erd (~/.erd.yaml) default configuration file.|],
B.append [r|output-format: pdf # Supported formats: |] (defVals fmts),
B.append [r|edge-style: spline # Supported values : |] (defVals edges)]
where
defVals = B.pack . concat . intersperse " " . M.keys
configIO :: IO Config
configIO = do
args <- getArgs
case O.getOpt O.Permute opts args of
(flags, [], []) -> do
conf <- foldl (\c app -> app c) (return defaultConfig) flags
let outpath = fst (cout conf)
return $
if isNothing (outfmt conf) && outpath /= "<stdout>" then
conf { outfmt = toGraphFmt $ takeExtension outpath }
else
conf
(_, _, errs@(_:_)) -> do
ef "Error(s) parsing flags:\n\t%s\n" $
intercalate "\n\t" $ map strip errs
exitFailure
(_, _, []) -> do
ef "erd does not have any positional arguments.\n\n"
usageExit
opts :: [O.OptDescr (IO Config -> IO Config)]
opts =
[ O.Option "c" ["config"]
(O.OptArg (\mf cIO -> cIO >>= \c -> do
globConfFile <- readGlobalConfigFile
f <- readConfigFile mf
case (f, globConfFile) of
(Nothing, Nothing) ->
B.putStr defaultConfigFile >> return c
(Nothing, Just globalC) ->
return c {outfmt = (toGraphFmt $ cFmtOut globalC),
edgeType = (toEdgeG $ cEdgeType globalC)}
(Just localC, _) ->
return c {outfmt = (toGraphFmt $ cFmtOut localC),
edgeType = (toEdgeG $ cEdgeType localC)}
) "FILE")
"Configuration file."
, O.Option "i" ["input"]
(O.ReqArg (\fpath cIO -> do
c <- cIO
i <- openFile fpath ReadMode
return $ c {cin = (fpath, i)}
)
"FILE")
("When set, input will be read from the given file.\n"
++ "Otherwise, stdin will be used.")
, O.Option "o" ["output"]
(O.ReqArg (\fpath cIO -> do
c <- cIO
o <- openFile fpath WriteMode
return $ c {cout = (fpath, o)}
)
"FILE")
("When set, output will be written to the given file.\n"
++ "Otherwise, stdout will be used.\n"
++ "If given and if --fmt is omitted, then the format will be\n"
++ "guessed from the file extension.")
, O.Option "h" ["help"]
(O.NoArg $ const usageExit)
"Show this usage message."
, O.Option "f" ["fmt"]
(O.ReqArg (\fmt cIO -> do
c <- cIO
let mfmt = toGraphFmt fmt
case mfmt of
Nothing -> do
ef "'%s' is not a valid output format." fmt
exitFailure
Just gfmt -> return c {outfmt = Just gfmt}
)
"FMT")
(printf "Force the output format to one of:\n%s"
(intercalate ", " $ M.keys fmts))
, O.Option "e" ["edge"]
(O.ReqArg (\edge cIO -> do
c <- cIO
let edgeG = toEdgeG edge
case edgeG of
Nothing -> do
ef "'%s' is not a valid type of edge." edge
exitFailure
Just x -> return c {edgeType = Just x}
)
"EDGE")
(printf "Select one type of edge:\n%s"
(intercalate ", " $ M.keys edges))
]
readGlobalConfigFile :: IO (Maybe ConfigFile)
readGlobalConfigFile = do
mHome <- tryJust (guard . isDoesNotExistError) getHomeDirectory
case mHome of
Left _ -> return Nothing
Right home -> readConfigFile $ Just (home </> ".erd.yaml")
readConfigFile :: Maybe FilePath -> IO (Maybe ConfigFile)
readConfigFile Nothing = return Nothing
readConfigFile (Just f) = do
mHome <- tryJust (guard . isDoesNotExistError) $ B.readFile f
case mHome of
Left _ -> return Nothing
Right home -> Y.decodeThrow home
fmts :: M.Map String (Maybe G.GraphvizOutput)
fmts = M.fromList
[ ("pdf", Just G.Pdf)
, ("svg", Just G.Svg)
, ("eps", Just G.Eps)
, ("bmp", Just G.Bmp)
, ("jpg", Just G.Jpeg)
, ("png", Just G.Png)
, ("gif", Just G.Gif)
, ("tiff", Just G.Tiff)
, ("dot", Just G.Canon)
, ("ps", Just G.Ps)
, ("ps2", Just G.Ps2)
, ("plain", Just G.Plain)
]
edges :: M.Map String (Maybe A.EdgeType)
edges = M.fromList
[ ("spline", Just A.SplineEdges)
, ("ortho", Just A.Ortho)
, ("noedge", Just A.NoEdges)
, ("poly", Just A.PolyLine)
, ("compound", Just A.CompoundEdge)
]
takeExtension :: String -> String
takeExtension s = if null rest then "" else reverse ext
where (ext, rest) = span (/= '.') $ reverse s
toGraphFmt :: String -> Maybe G.GraphvizOutput
toGraphFmt ext = M.findWithDefault Nothing ext fmts
toEdgeG :: String -> Maybe A.EdgeType
toEdgeG edge = M.findWithDefault Nothing edge edges
usageExit :: IO a
usageExit = usage >> exitFailure
usage :: IO ()
usage = ef "%s\n" $ O.usageInfo "Usage: erd [flags]" opts
ef :: HPrintfType r => String -> r
ef = hPrintf stderr
strip :: String -> String
strip = dropWhile isSpace . dropWhileEnd isSpace