module Data.Graph.Analysis.Reporting
(
Document(..),
DocumentGenerator(..),
Location(..),
DocElement(..),
DocInline(..),
GraphSize(..),
DocGraph(..),
VisParams(..),
VisProperties(..),
addLegend,
today,
tryCreateDirectory,
createGraph,
createSize,
unDotPath
) where
import Data.Graph.Inductive(Node)
import Data.GraphViz
import Data.Time(getZonedTime, zonedTimeToLocalTime, formatTime)
import Control.Exception.Extensible(SomeException(..), tryJust)
import System.Directory(createDirectoryIfMissing)
import System.FilePath((</>), makeRelative)
import System.Locale(defaultTimeLocale)
import Control.Monad(liftM, when)
data Document = Doc {
rootDirectory :: FilePath
, fileFront :: String
, graphDirectory :: FilePath
, title :: DocInline
, author :: String
, date :: String
, legend :: [(DocGraph, DocInline)]
, content :: [DocElement]
}
deriving (Eq, Ord, Show, Read)
class DocumentGenerator dg where
createDocument :: dg -> Document -> IO (Maybe FilePath)
docExtension :: dg -> String
data Location = Web String
| File FilePath
deriving (Eq, Ord, Show, Read)
data DocElement = Section DocInline [DocElement]
| Paragraph [DocInline]
| Enumeration [DocElement]
| Itemized [DocElement]
| Definitions [(DocInline, DocInline)]
| GraphImage DocGraph
deriving (Eq, Ord, Show, Read)
data DocInline = Text String
| BlankSpace
| Grouping [DocInline]
| Bold DocInline
| Emphasis DocInline
| DocLink DocInline Location
| DocImage DocInline Location
deriving (Eq, Ord, Show, Read)
data DocGraph = DG {
imageFile :: FilePath
, description :: DocInline
, dotGraph :: DotGraph Node
}
deriving (Eq, Ord, Show, Read)
data VisParams = VParams {
rootDir :: FilePath
, graphDir :: FilePath
, defaultImage :: VisProperties
, largeImage :: Maybe VisProperties
, saveDot :: Bool
}
deriving (Eq, Ord, Show, Read)
data VisProperties = VProps { size :: GraphSize
, format :: GraphvizOutput
}
deriving (Eq, Ord, Show, Read)
data GraphSize = GivenSize Point
| DefaultSize
deriving (Eq, Ord, Show, Read)
addLegend :: FilePath -> FilePath -> VisProperties
-> Document -> IO Document
addLegend fp gfp vp d = do mLg <- legendToElement fp gfp vp $ legend d
let es = content d
es' = maybe es (flip (:) es) mLg
return $ d { legend = []
, content = es'
}
legendToElement :: FilePath -> FilePath -> VisProperties
-> [(DocGraph, DocInline)]
-> IO (Maybe DocElement)
legendToElement _ _ _ [] = return Nothing
legendToElement fp gfp vp ls = do defs <- mapM (uncurry (legToDef fp gfp vp)) ls
let df = Definitions defs
return $ Just $ Section (Text "Legend") [df]
legToDef :: FilePath -> FilePath -> VisProperties
-> DocGraph -> DocInline
-> IO (DocInline, DocInline)
legToDef fp gfp vp dg def = liftM (flip (,) def)
$ graphImage' fp gfp vp' dg
where
vp' = vp { size = DefaultSize }
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 :: VisParams
-> DocGraph
-> IO DocElement
createGraph params dg
= do when (saveDot params) (graphImage rDir gDir vpD dgD >> return ())
dl <- graphImage' rDir gDir vp dg'
dl' <- maybe return tryImg mvp dl
return $ Paragraph [dl']
where
rDir = rootDir params
gDir = graphDir params
vp = defaultImage params
vpD = VProps { size = DefaultSize
, format = Canon
}
mvp = largeImage params
dg' = dg { imageFile = unDotPath $ imageFile dg }
dgL = checkLargeFilename vp mvp dg'
dgD = checkFilename vp vpD "dot" dg'
tryImg vp' di = liftM (either (const di) (DocLink di))
$ graphImage rDir gDir vp' dgL
checkLargeFilename :: VisProperties -> Maybe VisProperties
-> DocGraph -> DocGraph
checkLargeFilename _ Nothing dg = dg
checkLargeFilename vp1 (Just vp2) dg = checkFilename vp1 vp2 "large" dg
checkFilename :: VisProperties -> VisProperties -> String
-> DocGraph -> DocGraph
checkFilename vp1 vp2 s dg
| format vp1 == format vp2 = dg { imageFile = imageFile dg ++ '-' : s }
| otherwise = dg
graphImage :: FilePath -> FilePath -> VisProperties -> DocGraph
-> IO (Either DocInline Location)
graphImage rDir gDir vp dg = liftM (either' Text (File . fixPath))
$ addExtension (runGraphviz dot)
(format vp)
filename
where
dot = setSize vp $ dotGraph dg
filename = rDir </> gDir </> imageFile dg
fixPath = makeRelative rDir
graphImage' :: FilePath -> FilePath -> VisProperties -> DocGraph
-> IO DocInline
graphImage' rDir gDir vp dg = liftM (either id f)
$ graphImage rDir gDir vp dg
where
f = DocImage (description dg)
setSize :: VisProperties -> DotGraph a -> DotGraph a
setSize vp g = case size vp of
DefaultSize -> g
(GivenSize s) -> g { graphStatements = setS s}
where
setS s = stmts { attrStmts = sizeA s : attrStmts stmts }
stmts = graphStatements g
sizeA s = GraphAttrs [Size s]
createSize :: Double -> GraphSize
createSize w = GivenSize $ PointD w (w*4/6)
unDotPath :: FilePath -> FilePath
unDotPath = map replace
where
replace '.' = '-'
replace c = c
either' :: (a -> c) -> (b -> d) -> Either a b -> Either c d
either' fl _ (Left a) = Left $ fl a
either' _ fr (Right b) = Right $ fr b