module Data.Graph.Analysis.Reporting
(
Document(..),
DocumentGenerator(..),
Location(..),
DocElement(..),
DocInline(..),
GraphSize(..),
DocGraph,
addLegend,
today,
tryCreateDirectory,
createGraph,
createSize,
unDotPath
) where
import Data.Graph.Inductive(Node)
import Data.GraphViz
import Data.Maybe(isJust, fromJust, catMaybes)
import Data.Time(getZonedTime, zonedTimeToLocalTime, formatTime)
import Control.Exception.Extensible(SomeException(..), tryJust)
import System.Directory(createDirectoryIfMissing)
import System.FilePath((</>), (<.>))
import System.Locale(defaultTimeLocale)
data Document = Doc {
rootDirectory :: FilePath,
fileFront :: String,
graphDirectory :: FilePath,
title :: DocInline,
author :: String,
date :: String,
legend :: [(DocGraph, DocInline)],
content :: [DocElement]
}
class DocumentGenerator dg where
createDocument :: dg -> Document -> IO (Maybe FilePath)
docExtension :: dg -> String
data Location = Web String | File FilePath
instance Show Location where
show (Web url) = url
show (File fp) = fp
data DocElement = Section DocInline [DocElement]
| Paragraph [DocInline]
| Enumeration [DocElement]
| Itemized [DocElement]
| Definitions [(DocInline, DocInline)]
| GraphImage DocGraph
data DocInline = Text String
| BlankSpace
| Grouping [DocInline]
| Bold DocInline
| Emphasis DocInline
| DocLink DocInline Location
| DocImage DocInline Location
type DocGraph = (FilePath, DocInline, DotGraph Node)
addLegend :: FilePath -> FilePath -> Document -> IO Document
addLegend fp gfp d = do mLg <- legendToElement fp gfp $ legend d
let es = content d
es' = maybe es (flip (:) es) mLg
return $ d { legend = []
, content = es'
}
legendToElement :: FilePath -> FilePath -> [(DocGraph, DocInline)]
-> IO (Maybe DocElement)
legendToElement _ _ [] = return Nothing
legendToElement fp gfp ls = do mDefs <- mapM (uncurry (legToDef fp gfp)) ls
let defs = catMaybes mDefs
df = Definitions defs
sec = Section (Text "Legend") [df]
return $ Just sec
legToDef :: FilePath -> FilePath -> DocGraph -> DocInline
-> IO (Maybe (DocInline, DocInline))
legToDef fp gfp dg def = fmap (fmap (flip (,) def)) img
where
img = graphImage fp gfp DefaultSize Png "png" DocImage dg
today :: IO String
today = do zoneT <- getZonedTime
let localT = zonedTimeToLocalTime zoneT
return $ formatTime locale fmt localT
where
locale = defaultTimeLocale
fmt = "%A %e %B, %Y"
tryCreateDirectory :: FilePath -> IO Bool
tryCreateDirectory fp = do r <- tryJust (\(SomeException _) -> return ())
$ mkDir fp
return (isRight r)
where
mkDir = createDirectoryIfMissing True
isRight (Right _) = True
isRight _ = False
createGraph :: FilePath -> FilePath -> GraphSize -> Maybe GraphSize
-> DocGraph -> IO (Maybe DocElement)
createGraph fp gfp s ms (fn,inl,ag)
= do eImg <- gI s Png "png" DocImage fn inl Nothing
if isJust eImg
then case ms of
Nothing -> rt eImg
(Just s') -> rt =<< gI s' Svg "svg" DocLink fn' (toImg eImg) eImg
else return Nothing
where
fn' = fn ++ "-large"
i2e i = Just (i,Paragraph [i])
rt = return . fmap snd
toImg = fst . fromJust
gI a o e ln nm lb fl = do mImg <- graphImage fp gfp a o e ln (nm,lb,ag)
case mImg of
Nothing -> return fl
(Just img) -> return $ i2e img
graphImage :: FilePath -> FilePath -> GraphSize
-> GraphvizOutput -> FilePath
-> (DocInline -> Location -> DocInline)
-> DocGraph -> IO (Maybe DocInline)
graphImage fp gfp s output ext link (fn,inl,dg)
= do created <- runGraphviz dg' output filename'
if created
then return (Just img)
else return Nothing
where
dg' = setSize s dg
fn' = unDotPath fn
filename = gfp </> fn' <.> ext
filename' = fp </> filename
loc = File filename
img = link inl loc
data GraphSize = GivenSize Point
| DefaultSize
setSize :: GraphSize -> DotGraph a -> DotGraph a
setSize DefaultSize g = g
setSize (GivenSize p) g = g { graphStatements = stmts' }
where
stmts = graphStatements g
stmts' = stmts { attrStmts = a : attrStmts stmts }
a = GraphAttrs [s]
s = Size p
createSize :: Double -> GraphSize
createSize w = GivenSize $ PointD w (w*4/6)
unDotPath :: FilePath -> FilePath
unDotPath = map replace
where
replace '.' = '-'
replace c = c