{- Copyright (C) 2012-2014 Michal Antkiewicz, Chris Walker Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -} -- | A plugin for Gitit which integrates the Clafer compiler and links to other -- Clafer web tools: , -- , and -- module Network.Gitit.Plugin.ClaferWiki (plugin) where import Network.Gitit.Interface import Control.Applicative import Control.Monad import Control.Monad.Trans.State import Data.List import Data.List.Split import qualified Data.Map as Map import Data.String.Utils (replace) import Network.BSD (getHostName) import System.Directory (createDirectoryIfMissing, doesFileExist) import System.Process (readProcessWithExitCode) import Language.Clafer import Language.Clafer.Css as Css import Language.Clafer.Generator.Html (highlightErrors) -- | claferWiki collects Clafer code from .clafer code blocks, renders as HTML and graph, -- and replaces the original blocks with RawBlocks containing the results plugin :: Plugin plugin = mkPageTransformM claferWiki claferWiki :: Pandoc -> PluginM Pandoc claferWiki pandoc = do -- make sure the directories and clafer.css exist liftIO $ do createDirectoryIfMissing True "static/clafer/" createDirectoryIfMissing True "static/css/" cssExist <- doesFileExist "static/css/clafer.css" unless cssExist $ writeFile "static/css/clafer.css" css serverURL <- liftIO $ getHostName pageName <- getPageName config <- askConfig let serverPort = show $ portNumber config -- produce the required outputs in a single compilation allCompilationResults = compileFragments fragments claferModes htmlCode = extractOutput allCompilationResults Html htmlCodeFragments = splitOn "\n\n" htmlCode stats = maybe "No model." statistics $ extractCompilerResult allCompilationResults Html dotGraph = maybe "" outputCode $ extractCompilerResult allCompilationResults Graph dotCVLGraph = maybe "" outputCode $ extractCompilerResult allCompilationResults CVLGraph -- render the graphs to SVG using dot (_, svgGraphWithoutRefs, _) <- liftIO $ readProcessWithExitCode "dot" [ "-Tsvg" ] dotGraph (_, svgGraphWithRefs, _) <- liftIO $ readProcessWithExitCode "dot" [ "-Tsvg" ] $ changeTransparentToLightGray dotGraph (_, svgCVLGraph, _) <- liftIO $ readProcessWithExitCode "dot" [ "-Tsvg" ] dotCVLGraph -- using the WikiEnv as state, replace clafer code blocks with appropriate results: -- html rendering of clafer code, graph rendering, download links, ide, configurator, and visualizer buttons let initialWikiEnv = WikiEnv { we_fileName = pageName, we_serverURL = serverURL, we_serverPort = serverPort, we_htmlCodeFragments = htmlCodeFragments, we_stats = stats, we_graphNo = 0, -- needed to construct unique IDs of
for graphs we_svgGraphWithRefs = svgGraphWithRefs, we_svgGraphWithoutRefs = svgGraphWithoutRefs, we_svgCVLGraph = svgCVLGraph } newPandoc = evalState (bottomUpM replaceClaferWikiBlocks pandoc) initialWikiEnv -- save original model liftIO $ writeFile ("static/clafer/" ++ pageName ++ ".cfr") completeModel -- save html version liftIO $ writeFile ("static/clafer/" ++ pageName ++ ".html") $ selfContained htmlCode return $ newPandoc where -- collect clafer model fragments fragments :: [ String ] fragments = queryWith addFragment pandoc -- collects compiler modes depending on the kinds of blocks on the page claferModes :: [ ClaferMode ] claferModes = nub $ queryWith addMode pandoc fragmentedModel = intercalate "//# FRAGMENT\n" fragments completeModel = intercalate "\n" fragments addFragment :: Block -> [String] addFragment (CodeBlock (_, [ "clafer" ], _) code) = [ code ++ "\n" ] addFragment _ = [] addMode :: Block -> [ClaferMode] addMode (CodeBlock (_, [ "clafer" ], _) _) = [Html] addMode (CodeBlock (_, [ "clafer", "graph" ], _) _) = [Graph] addMode (CodeBlock (_, [ "clafer", "summary" ], _) _) = [Graph] addMode (CodeBlock (_, [ "clafer", "cvlGraph" ], _) _) = [CVLGraph] addMode (CodeBlock (_, [ "clafer", "cvlgraph" ], _) _) = [CVLGraph] addMode _ = [] extractCompilerResult :: Either [ClaferErr] (Map.Map ClaferMode CompilerResult) -> ClaferMode -> Maybe CompilerResult extractCompilerResult result claferMode = either (const Nothing) (Map.lookup claferMode) result extractOutput :: Either [ClaferErr] (Map.Map ClaferMode CompilerResult) -> ClaferMode -> String extractOutput (Right compilerResultMap) claferMode = case (Map.lookup claferMode compilerResultMap) of Just CompilerResult{outputCode = output} -> output Nothing -> "Error: No " ++ show claferMode ++ " output!" extractOutput (Left err) _ = highlightErrors fragmentedModel err selfContained htmlCode = concat [ Css.header, "", "\n\n", htmlCode, "\n" ] -- | Environment (state) for rewriting the page data WikiEnv = WikiEnv { we_fileName :: String, we_serverURL :: String, we_serverPort :: String, -- | code fragments are consumed we_htmlCodeFragments :: [ String ], we_stats :: String, we_graphNo :: Int, we_svgGraphWithRefs :: String, we_svgGraphWithoutRefs :: String, we_svgCVLGraph :: String } replaceClaferWikiBlocks :: Block -> State WikiEnv Block replaceClaferWikiBlocks (CodeBlock (_, [ "clafer" ], _) _) = do wikiEnv <- get let (fragment:fragments) = we_htmlCodeFragments wikiEnv put $ wikiEnv { we_htmlCodeFragments = fragments } return $ RawBlock "html" ("
" ++ fragment ++ "
") replaceClaferWikiBlocks (CodeBlock (_, [ "clafer", "links" ], _) _) = do fileName <- gets we_fileName return $ RawBlock "html" $ renderLinks fileName replaceClaferWikiBlocks (CodeBlock (_, [ "clafer", "stats" ], _) _) = do stats <- gets we_stats return $ RawBlock "html" $ renderStats stats replaceClaferWikiBlocks (CodeBlock (_, [ "clafer", "graph" ], _) _) = do wikiEnv <- get graphNo <- gets we_graphNo svgGraphWithRefs <- gets we_svgGraphWithRefs svgGraphWithoutRefs <- gets we_svgGraphWithoutRefs put $ wikiEnv { we_graphNo = graphNo + 1 } return $ RawBlock "html" $ renderGraphWithToggle svgGraphWithoutRefs svgGraphWithRefs graphNo replaceClaferWikiBlocks (CodeBlock (_, [ "clafer", "cvlGraph" ], _) _) = do svgCVLGraph <- gets we_svgCVLGraph return $ RawBlock "html" $ renderGraph svgCVLGraph replaceClaferWikiBlocks (CodeBlock (_, [ "clafer", "cvlgraph" ], _) _) = do svgCVLGraph <- gets we_svgCVLGraph return $ RawBlock "html" $ renderGraph svgCVLGraph replaceClaferWikiBlocks (CodeBlock (_, [ "clafer", "summary" ], _) _) = do wikiEnv <- get fileName <- gets we_fileName stats <- gets we_stats graphNo <- gets we_graphNo svgGraphWithRefs <- gets we_svgGraphWithRefs svgGraphWithoutRefs <- gets we_svgGraphWithoutRefs put $ wikiEnv { we_graphNo = graphNo + 1 } return $ RawBlock "html" $ renderSummary fileName stats svgGraphWithoutRefs svgGraphWithRefs graphNo replaceClaferWikiBlocks (CodeBlock (_, [ "clafer", "mooviz" ], _) _) = do wikiEnv <- get return $ renderAnalyzeWithClaferMooViz (we_fileName wikiEnv) (we_serverURL wikiEnv) (we_serverPort wikiEnv) replaceClaferWikiBlocks (CodeBlock (_, [ "clafer", "config" ], _) _) = do wikiEnv <- get return $ renderConfigureWithClaferConfigurator (we_fileName wikiEnv) (we_serverURL wikiEnv) (we_serverPort wikiEnv) replaceClaferWikiBlocks (CodeBlock (_, [ "clafer", "ide" ], _) _) = do wikiEnv <- get return $ renderAddOpenInIDE (we_fileName wikiEnv) (we_serverURL wikiEnv) (we_serverPort wikiEnv) replaceClaferWikiBlocks block = return block renderLinks :: String -> String renderLinks fileName = "
Module Downloads: | [.cfr] | [.html] |

\n" renderStats :: String -> String renderStats stats = "
Module Statistics: \n| " ++ (intercalate " | " $ lines stats ) ++ " |

\n" renderGraphWithToggle :: String -> String -> Int -> String renderGraphWithToggle svgGraphWithoutRefs svgGraphWithRefs graphNo = unlines [ "
", svgGraphWithoutRefs, "
", "
", svgGraphWithRefs, "
" ] renderGraph :: String -> String renderGraph svgGraph = unlines [ "
", svgGraph, "
" ] renderShowRefs :: Int -> String renderShowRefs graphNo = "var gwr=document.getElementById('" ++ renderGraphId True graphNo ++ "'); gwr.style.display='block'; gwr.scrollLeft=this.scrollLeft; this.style.display='none';" renderHideRefs :: Int -> String renderHideRefs graphNo = "var gwor=document.getElementById('" ++ renderGraphId False graphNo ++ "'); gwor.style.display='block'; gwor.scrollLeft=this.scrollLeft;this.style.display='none';" renderGraphId :: Bool -> Int -> String renderGraphId True graphNo = "graphWithRefs" ++ show graphNo renderGraphId False graphNo = "graphWithoutRefs" ++ show graphNo renderSummary :: String -> String -> String -> String -> Int -> String renderSummary fileName stats svgGraphWithoutRefs svgGraphWithRefs graphNo = renderGraphWithToggle svgGraphWithoutRefs svgGraphWithRefs graphNo ++ renderStats stats ++ renderLinks fileName compileFragments :: [ String ] -> [ ClaferMode ] -> Either [ClaferErr] (Map.Map ClaferMode CompilerResult) compileFragments fragments claferModes = -- compile all clafer code runClafer defaultClaferArgs{ mode=claferModes, keep_unused=True, add_comments=True, show_references=False } $ do mapM_ addModuleFragment fragments parse compile generate renderAnalyzeWithClaferMooViz :: String -> String -> String -> Block renderAnalyzeWithClaferMooViz fileName serverURL serverPort = RawBlock "html" (unlines [ "
\n" ]) renderConfigureWithClaferConfigurator :: String -> String -> String -> Block renderConfigureWithClaferConfigurator fileName serverURL serverPort = RawBlock "html" (unlines [ "
\n" ]) renderAddOpenInIDE :: String -> String -> String -> Block renderAddOpenInIDE fileName serverURL serverPort = RawBlock "html" (unlines [ "
\n" ]) getPageName:: PluginM String getPageName = replace " " "_" . replace "/" "_" . pgPageName . ctxLayout <$> getContext changeTransparentToLightGray :: String -> String changeTransparentToLightGray = replace "color=transparent" "color=lightgray"