diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,3 @@ +* 0.2.0.0: 26 August 2012 + + Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Brent Yorgey + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Brent Yorgey nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/diagrams-builder.cabal b/diagrams-builder.cabal new file mode 100644 --- /dev/null +++ b/diagrams-builder.cabal @@ -0,0 +1,88 @@ +name: diagrams-builder +version: 0.2.0.0 +synopsis: hint-based build service for the diagrams graphics EDSL. + +description: @diagrams-builder@ provides backend-agnostic tools for + dynamically turning code into rendered diagrams, + using the @hint@ wrapper to the GHC API. It + supports conditional recompilation using hashing + of diagrams source code, to avoid recompiling + code that has not changed. It is useful for + creating tools which compile diagrams code + embedded in other documents. For example, it is + used by the @BlogLiterately-diagrams@ package (a + plugin for @BlogLiterately@) to compile diagrams + embedded in Markdown-formatted blog posts. + . + An executable specific to the cairo backend is + included (more executables specific to other + backends will be included in the future). It + takes an input file and an expression to render + and outputs an image file, using the cairo + backend. If you want it you must explicitly + enable the cairo flag with @-fcairo@. + . + A LaTeX package, @diagrams-latex.sty@, is also + provided in the @latex/@ directory of the source + distribution, which renders diagrams code found + within @diagram@ environments. It makes use of + the @diagrams-builder-cairo@ executable, so if + you want to use @diagrams-latex.sty@ you should + install @diagrams-builder@ with the @-fcairo@ + option. Note that @diagrams-latex.sty@ is + licensed under the GPL. +homepage: http://projects.haskell.org/diagrams +license: BSD3 +license-file: LICENSE +extra-source-files: CHANGES, latex/diagrams-latex.sty +author: Brent Yorgey +maintainer: diagrams-discuss@googlegroups.com +category: Graphics +build-type: Simple +cabal-version: >=1.10 +bug-reports: https://github.com/diagrams/diagrams-builder/issues +Source-repository head + type: git + location: https://github.com/diagrams/diagrams-builder + +library + exposed-modules: Diagrams.Builder + Diagrams.Builder.Modules + build-depends: base >=4.2 && < 4.7, + diagrams-lib >=0.3 && < 0.6, + hint ==0.3.*, + directory, + filepath, + haskell-src-exts >= 1.13.1 && < 1.14, + cryptohash >= 0.7.4 && < 0.8, + bytestring >= 0.9.2 && < 0.10, + base16-bytestring >= 0.1.1 && < 0.2 + hs-source-dirs: src + default-language: Haskell2010 + other-extensions: StandaloneDeriving, + DeriveDataTypeable, + ScopedTypeVariables, + FlexibleContexts + +flag cairo + description: install cairo-specific builder tool + default: False + +executable diagrams-builder-cairo + main-is: diagrams-builder-cairo.hs + hs-source-dirs: src/tools + default-language: Haskell2010 + other-extensions: StandaloneDeriving, + DeriveDataTypeable + + if !flag(cairo) + buildable: False + + if flag(cairo) + build-depends: base >= 4 && < 5, + filepath, + directory, + diagrams-builder, + diagrams-lib >= 0.5 && < 0.6, + diagrams-cairo >= 0.5 && < 0.6, + cmdargs >= 0.6 && < 0.11 diff --git a/latex/diagrams-latex.sty b/latex/diagrams-latex.sty new file mode 100644 --- /dev/null +++ b/latex/diagrams-latex.sty @@ -0,0 +1,224 @@ +%% To use, simply create diagram environments with code, being sure to +%% declare something named 'dia' in each, which will be rendered. For example: +%% +%% \begin{diagram}[width=200] +%% import Data.List +%% dia = hcat . map circle . sort $ [4,8,9,2,3,6] +%% \end{diagram} + + +%% diagrams-latex.sty +%% Copyright (c) 2011-2012, Ryan Yates +%% +%% Large portions copied from dot2texi.sty +%% +%% Copyright (c) 2007-2008, Kjell Magne Fauske +%% +%% Author: Kjell Magne Fauske +%% http://www.fauskes.net +%% + +%% Copyright (c) 2005, Lars Kotthoff +%% +%% Large portions copied from pdftex, +%% Copyright (c) 2001-3, Radhakrishnan CV +%% Rajagopal CV +%% http://www.river-valley.com +%% +%% River Valley Technologies, Floor III, SJP Buildings, Cotton Hills +%% Trivandrum, India 695014 +%% +%% Tel: +91 471 233 7501 +%% +%% Antoine Chambert-Loir +%% +%% http://www.math.polytechnique.fr/\protect \unhbox \voidb@x \penalty \@M \ {}chambert +%% +%% Ecole polytechnique, Palaiseau Cedex, France +%% +%% This program is free software; you can redistribute it and/or +%% modify it under the terms of the GNU General Public License +%% as published by the Free Software Foundation; either version 2 +%% of the License, or (at your option) any later version. +%% +%% This program is distributed in the hope that it will be useful, +%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%% GNU General Public License for more details. +%% +%% You should have received a copy of the GNU General Public License +%% along with this program (gpl.txt); if not, write to the Free +%% Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +%% MA 02111-1307, USA. +%% + +%% Copyright (C) 2007 by Will Robertson & Johannes Große + +\NeedsTeXFormat{LaTeX2e}[1999/12/01] +\ProvidesPackage{diagrams-latex}[2012/04/07 v0.1 Generate diagrams embedded within LaTeX] +\RequirePackage{moreverb} +\RequirePackage{xkeyval}[2005/02/22] + +\newif\ifdtt@ShellEscape +%\newif\ifmiktex \miktexfalse +\newif\ifdtt@ForceShellEscape \dtt@ForceShellEscapefalse +\newif\ifdtt@debug \dtt@debugfalse +\newif\ifdtt@autosize \dtt@autosizefalse +% Options related to shell escape +\DeclareOptionX{shell}{\dtt@ShellEscapetrue} +\DeclareOptionX{noshell}{\dtt@ShellEscapefalse} +\DeclareOptionX{forceshell}{\dtt@ForceShellEscapetrue\dtt@ShellEscapetrue} +\DeclareOptionX{miktex}{} % dummy (for backwards compatability) + +% Options for setting output size +\DeclareOptionX{width}[]{\def\dtt@width{-w #1}} +\def\dtt@width{} % default output width +\DeclareOptionX{height}[]{\def\dtt@height{-h #1}} +\def\dtt@height{} % default output height + +% Option for setting an output directory +\DeclareOptionX{outputdir}[]{\def\dtt@outputdir{#1}} +\def\dtt@outputdir{} +\DeclareOptionX{debug}{\dtt@debugtrue} + +\newcommand\setoutputdir[1]{\def\dtt@outputdir{#1}} + +\ExecuteOptionsX{shell} + +\ProcessOptionsX\relax + + +%% The platform detection code is copied from the ifplatform package +%% avaialable from: http://tug.ctan.org/tex-archive/macros/latex/contrib/ifplatform/ +%% Copyright (C) 2007 by Will Robertson & Johannes Große +\newif\ifdtt@ShellEscapeEnabled +\newif\ifwindows +\edef\ip@file{\jobname.w18} +\edef\ip@sig{write18-test-\the\year\the\month\the\day\the\time} +\edef\ip@win{'\ip@sig'} +\def\ip@read@file{% + \newread\instream + \openin\instream=\ip@file + \@tempcnta=\endlinechar + \endlinechar=-1 + \read\instream to\@tempa + \endlinechar=\@tempcnta + \closein\instream} +\immediate\write18{echo \ip@win >"\ip@file"} +\IfFileExists{\ip@file}{\dtt@ShellEscapeEnabledtrue}{\dtt@ShellEscapeEnabledfalse} +\ifdtt@ShellEscapeEnabled + \ip@read@file + \ifx\@tempa\ip@sig + \windowsfalse + \else + \ifx\@tempa\ip@win + \windowstrue + \fi + \fi + \immediate\write18{\ifwindows del \else rm -- \fi "\ip@file"} +\fi + +\ifdtt@ForceShellEscape + \PackageInfo{diagrams-latex} + {ForceShellEscape enabled} +\fi + +\ifdtt@ShellEscapeEnabled + \PackageInfo{diagrams-latex} + {XXX} +\else + \PackageWarningNoLine{diagrams-latex} + {Shell escape not enabled.\MessageBreak + You'll need to compile the diagrams yourself.} +\fi +\newcounter{dtt@fignum} +\def\dtt@figname{\dtt@outputdir\jobname-diagrams-latex-fig\thedtt@fignum} + + +%%%%%%%%%%%%%%%%% diagrams-latex code +% Most of the code is from dot2texi.sty + +% Options +\define@key{dtt}{width}[]{% + \def\dtt@width{-w #1} +} +\define@key{dtt}{height}[]{% + \def\dtt@height{-h #1} +} + +\define@key{dtt}{outputdir}[]{% + \def\dtt@outputdir{#1} +} +\define@key{dtt}{file}[]{% + \def\dtt@figname{\dtt@outputdir#1} +} + +\define@key{dtt}{shell}[]{\dtt@ShellEscapetrue} +\define@key{dtt}{noshell}[]{\dtt@ShellEscapefalse} + +\newif\ifdtt@writetofile \dtt@writetofiletrue + +\newwrite\verbatim@out +\def\diagramslatexverbatimwrite#1{% + \def\BeforeStream{ + \message{Opening diagrams-latex stream #1}% + }% + \@bsphack + \immediate\openout \verbatim@out #1 + \BeforeStream% + \let\do\@makeother\dospecials + \catcode`\^^M\active + \def\verbatim@processline{% + \immediate\write\verbatim@out + {\the\verbatim@line}}% + \verbatim@start% +} + +\def\enddiagramslatexverbatimwrite{% + \immediate\closeout\verbatim@out + \@esphack + \catcode`\\0 + \catcode`\{1 + \catcode`\}2 + \catcode`\$3 + \catcode`\&4 + \catcode`\^^M5 + \catcode`\#6 + \catcode`\^7 + \catcode`\_8 + \catcode`\~9% Added this one + \catcode`\ 10 + \catcode`\%14} + +\newenvironment{diagram}[1][]{\stepcounter{dtt@fignum}% + \setkeys{dtt}{#1} + \ifdtt@ForceShellEscape + \dtt@ShellEscapetrue + \fi + \xdef\diagramslatexCutFile{\dtt@figname.txt} + \diagramslatexverbatimwrite{\diagramslatexCutFile}} + {\enddiagramslatexverbatimwrite% + \diagramslatexgraphicsinclude} + +\long\gdef\diagramslatexgraphicsprocess{% + \ifdtt@ShellEscape + \IfFileExists{\dtt@figname.txt}{% + \immediate\write18{diagrams-builder-cairo -o \dtt@figname.pdf\space + \dtt@width\space + \dtt@height\space + \dtt@figname.txt\space }% + \IfFileExists{\dtt@figname.pdf}{% + \PackageInfo{diagrams-latex}{\dtt@figname.txt converted} + } + {\PackageWarningNoLine{diagrams-latex} + {Conversion of \dtt@figname.txt failed}}}{} + \fi +} + +\long\gdef\diagramslatexgraphicsinclude{\diagramslatexgraphicsprocess% + \IfFileExists{\dtt@figname.pdf}{{\includegraphics{\dtt@figname.pdf}}} + {\PackageWarningNoLine{diagrams-latex} + {Please convert \dtt@figname.txt manually}} +} + +\endinput diff --git a/src/Diagrams/Builder.hs b/src/Diagrams/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Builder.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE StandaloneDeriving + , DeriveDataTypeable + , ScopedTypeVariables + , FlexibleContexts + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Builder +-- Copyright : (c) 2012 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Tools for dynamically building diagrams, for /e.g./ creating +-- preprocessors to interpret diagrams code embedded in documents. +-- +----------------------------------------------------------------------------- +module Diagrams.Builder + ( -- * Building diagrams + + buildDiagram, BuildResult(..) + , ppInterpError + + -- ** Regeneration decision functions + , alwaysRegenerate, hashedRegenerate + + -- * Interpreting diagrams + -- $interp + , setDiagramImports + , interpretDiagram + + ) where + +import Diagrams.Builder.Modules + +import Diagrams.Prelude hiding ((<.>), e) + +import Language.Haskell.Exts (prettyPrint) +import Language.Haskell.Interpreter hiding (ModuleName) + +import System.IO +import System.FilePath +import System.Directory + +import Crypto.Hash.MD5 + +import qualified Data.ByteString.Char8 as B +import Data.ByteString.Base16 +import Data.List (nub) +import Data.Typeable +deriving instance Typeable Any + +------------------------------------------------------------ +-- Interpreting diagrams +------------------------------------------------------------ + +-- $interp +-- These functions constitute the internals of diagrams-builder. End +-- users should not usually need to call them directly; use +-- 'buildDiagram' instead. + +-- | Set up the module to be interpreted, in the context of the +-- necessary imports. +setDiagramImports :: MonadInterpreter m + => String -- ^ Filename of the module containing the diagrams + -> [String] -- ^ Additional necessary + -- imports. @Prelude@, + -- @Diagrams.Prelude@, + -- @Graphics.Rendering.Diagrams.Core@, + -- and @Data.Monoid@ are included + -- by default. + -> m () +setDiagramImports m imps = do + loadModules [m] + setTopLevelModules [takeBaseName m] + setImports $ [ "Prelude" + , "Diagrams.Prelude" + , "Graphics.Rendering.Diagrams.Core" + , "Data.Monoid" + ] + ++ imps + +-- | Interpret a diagram expression based on the contents of a given +-- source file, using some backend to produce a result. +interpretDiagram :: forall b v. + ( Typeable b, Typeable v + , InnerSpace v, OrderedField (Scalar v), Backend b v + ) + => b -- ^ Backend token + -> v -- ^ Dummy vector to identify the vector space + -> Options b v -- ^ Rendering options + -> FilePath -- ^ Filename of the module containing the example + -> [String] -- ^ Additional imports needed + -> String -- ^ Expression of type @Diagram b v@ to be compiled + -> IO (Either InterpreterError (Result b v)) +interpretDiagram b _ opts m imps dexp = + runInterpreter $ do + setDiagramImports m imps + d <- interpret dexp (as :: Diagram b v) + return (renderDia b opts d) + +-- | Pretty-print an @InterpreterError@. +ppInterpError :: InterpreterError -> String +ppInterpError (UnknownError err) = "UnknownError: " ++ err +ppInterpError (WontCompile es) = unlines . nub . map errMsg $ es +ppInterpError (NotAllowed err) = "NotAllowed: " ++ err +ppInterpError (GhcException err) = "GhcException: " ++ err + +------------------------------------------------------------ +-- Build a diagram using a temporary file +------------------------------------------------------------ + +-- | Potential results of a dynamic diagram building operation. +data BuildResult b v x = + ParseErr String -- ^ Parsing of the code failed. + | InterpErr InterpreterError -- ^ Interpreting the code + -- failed. See 'ppInterpError'. + | Skipped x -- ^ This diagram did not need to be + -- regenerated. + | OK x (Result b v) -- ^ A successful build, yielding a + -- backend-specific result and + -- some extra information. + +-- | Build a diagram by writing the given source code to a temporary +-- module and interpreting the given expression. Can return either +-- a parse error if the source does not parse, an interpreter error, +-- or the final result. +buildDiagram :: ( Typeable b, Typeable v + , InnerSpace v, OrderedField (Scalar v), Backend b v + ) + => b -- ^ Backend token + -> v -- ^ Dummy vector to fix the vector type + -> Options b v -- ^ Backend-specific options to use + -> [String] -- ^ Source code snippets. Each should + -- be a syntactically valid Haskell + -- module. They will be combined + -- intelligently, /i.e./ not just + -- pasted together textually but + -- combining pragmas, imports, + -- /etc./ separately. + -> String -- ^ Diagram expression to interpret + -> [String] -- ^ Extra @LANGUAGE@ pragmas to use + -- (@NoMonomorphismRestriction@ is used + -- by default.) + -> [String] -- ^ Additional imports + -- ("Diagrams.Prelude" is imported by + -- default). + -> (String -> IO (x, Maybe (Options b v -> Options b v))) + -- ^ A function to decide whether a + -- particular diagram needs to be + -- regenerated. It will be passed + -- the final assembled source for the + -- diagram (but with the module name + -- set to @Main@ instead of something + -- auto-generated, so that hashing + -- the source will produce consistent + -- results across runs). It can + -- return some information (such as a + -- hash of the source) via the @x@ + -- result, which will be passed + -- through to the result of + -- 'buildDiagram'. More importantly, + -- it decides whether the diagram + -- should be built: a result of + -- 'Just' means the diagram /should/ + -- be built; 'Nothing' means it + -- should not. In the case that it + -- should be built, it returns a + -- function for updating the + -- rendering options. This could be + -- used, /e.g./, to request a + -- filename based on a hash of the + -- source. + -- + -- Two standard decision functions + -- are provided for convenience: + -- 'alwaysRegenerate' returns no + -- extra information and always + -- decides to regenerate the diagram; + -- 'hashedRegenerate' creates a hash + -- of the diagram source and looks + -- for a file with that name in a + -- given directory. + -> IO (BuildResult b v x) +buildDiagram b v opts source dexp langs imps shouldRegen = do + let source' = map unLit source + case createModule + Nothing + ("NoMonomorphismRestriction" : langs) + ("Diagrams.Prelude" : imps) + source' of + Left err -> return (ParseErr err) + Right m -> do + regen <- shouldRegen (prettyPrint m ++ dexp) + case regen of + (info, Nothing) -> return $ Skipped info + (info, Just upd) -> do + tmpDir <- getTemporaryDirectory + (tmp, h) <- openTempFile tmpDir ("Diagram.hs") + let m' = replaceModuleName (takeBaseName tmp) m + hPutStr h (prettyPrint m') + hClose h + + compilation <- interpretDiagram b v (upd opts) tmp imps dexp + removeFile tmp + return $ either InterpErr (OK info) compilation + +-- | Convenience function suitable to be given as the final argument +-- to 'buildDiagram'. It implements the simple policy of always +-- rebuilding every diagram. +alwaysRegenerate :: String -> IO ((), Maybe (a -> a)) +alwaysRegenerate _ = return ((), Just id) + +-- | Convenience function suitable to be given as the final argument +-- to 'buildDiagram'. It works by hashing the given diagram source, +-- and looking in the specified directory for any file whose base +-- name is equal to the hash. If there is such a file, it specifies +-- that the diagram should not be rebuilt. Otherwise, it specifies +-- that the diagram should be rebuilt, and uses the provided +-- function to update the rendering options based on the generated +-- hash. (Most likely, one would want to set the requested output +-- file to the hash followed by some extension.) It also returns +-- the generated hash. +hashedRegenerate :: (String -> a -> a) -- ^ A function for computing + -- an update to rendering + -- options, given a new base + -- filename computed from a + -- hash of the diagram + -- source. + -> FilePath -- ^ The directory in which to + -- look for generated files + -> String -- ^ The \"source\" to + -- hash. Note that this does + -- not actually have to be + -- valid source code. A + -- common trick is to + -- concatenate the actual + -- source code with String + -- representations of any + -- other information on which + -- the diagram depends. + -> IO (String, Maybe (a -> a)) +hashedRegenerate upd dir src = do + let fileBase = B.unpack . encode . hash . B.pack $ src + files <- getDirectoryContents dir + case any ((fileBase==) . takeBaseName) files of + True -> return (fileBase, Nothing) + False -> return (fileBase, Just (upd fileBase)) diff --git a/src/Diagrams/Builder/Modules.hs b/src/Diagrams/Builder/Modules.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Builder/Modules.hs @@ -0,0 +1,117 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Builder.Modules +-- Copyright : (c) 2012 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Tools used by diagrams-builder for manipulating Haskell modules. +-- +----------------------------------------------------------------------------- + +module Diagrams.Builder.Modules where + +import Data.Function (on) +import Data.List (foldl1', isPrefixOf, groupBy, sortBy, nub) +import Data.Ord (comparing) + +import Language.Haskell.Exts +import Language.Haskell.Exts.SrcLoc (noLoc) + +------------------------------------------------------------ +-- Manipulating modules +------------------------------------------------------------ + +-- | Extend some snippets of source code into a proper module, by +-- combining them intelligently (preserving imports, pragmas, /etc./), +-- (possibly) giving it a different name, and adding @LANGUAGE@ pragmas +-- and imports if necessary. Only those pragmas and imports which +-- are not already included in the code will be added. +-- +-- Returns the updated module, or an error message if parsing +-- failed. +createModule :: Maybe String -- ^ Module name to use + -> [String] -- ^ @LANGUAGE@ pragmas to add + -> [String] -- ^ Imports to add + -> [String] -- ^ Source code + -> Either String Module +createModule _ _ _ [] = Left "createModule: no source code given" +createModule nm langs imps srcs = do + ms <- mapM doModuleParse srcs + return + . deleteExports + . maybe id replaceModuleName nm + . addPragmas langs + . addImports imps + . foldl1' combineModules + $ ms + +-- | Run the haskell-src-exts parser on a @String@ representing some +-- Haskell code, producing a @Module@ or an error message. +doModuleParse :: String -> Either String Module +doModuleParse src = + case parseFileContents src of + ParseFailed _ err -> Left err + ParseOk m -> return m + +-- | Remove all the literate comments and bird tracks from a literate +-- Haskell file. Has no effect on non-literate source. +unLit :: String -> String +unLit src + | any ("> " `isPrefixOf`) ls = unlines . map (drop 2) . filter ("> " `isPrefixOf`) $ ls + | otherwise = src + where ls = lines src + +-- | Replace the name of a module. +replaceModuleName :: String -> Module -> Module +replaceModuleName m (Module l _ p w e i d) = Module l (ModuleName m) p w e i d + +-- | Delete module exports. +deleteExports :: Module -> Module +deleteExports (Module l n p w _ i d) = Module l n p w Nothing i d + +-- | Add some @LANGUAGE@ pragmas to a module if necessary. +addPragmas :: [String] -> Module -> Module +addPragmas langs (Module l n p w e i d) = Module l n (f p) w e i d + where f [] = [LanguagePragma noLoc (map Ident langs)] + f (LanguagePragma loc ps : rest) = LanguagePragma loc (ps ++ map Ident langs) : rest + f (x : rest) = x : f rest + +-- | Add some imports to a module if necessary. +addImports :: [String] -> Module -> Module +addImports imps (Module l n p w e i d) = Module l n p w e (foldr addImport i imps) d + where addImport imp is + | any ((==imp) . getModuleName . importModule) is = is + | otherwise = ImportDecl noLoc (ModuleName imp) False False Nothing Nothing Nothing : is + +-- | Combine two modules into one, with a left bias in the case of +-- things that can't be sensibly combined (/e.g./ the module name). +-- Note that combining multiple imports of the same module with +-- different import specifications (qualification, hiding, explicit +-- import) is unlikely to work sensibly. +combineModules :: Module -> Module -> Module +combineModules (Module l1 n1 ps1 w1 e1 i1 d1) + (Module _ _ ps2 _ _ i2 d2) = + Module l1 n1 combinedPragmas w1 e1 combinedImports (d1 ++ d2) + where + combinedPragmas = combinedLangPragmas ++ otherPragmas ps1 ++ otherPragmas ps2 + combinedImports = map head + . groupBy ((==) `on` importModule) + . sortBy (comparing importModule) + $ i1 ++ i2 + + combinedLangPragmas + = [LanguagePragma noLoc (nub (getLangPragmas ps1 ++ getLangPragmas ps2))] + + getLangPragmas = concatMap getLangPragma + getLangPragma (LanguagePragma _ ns) = ns + getLangPragma _ = [] + + otherPragmas = filter (not . isLangPragma) + isLangPragma (LanguagePragma {}) = True + isLangPragma _ = False + +-- | Convert a @ModuleName@ to a @String@. +getModuleName :: ModuleName -> String +getModuleName (ModuleName n) = n + diff --git a/src/tools/diagrams-builder-cairo.hs b/src/tools/diagrams-builder-cairo.hs new file mode 100644 --- /dev/null +++ b/src/tools/diagrams-builder-cairo.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} + +module Main where + +import Diagrams.Prelude hiding (width, height) +import Diagrams.Backend.Cairo +import Diagrams.Backend.Cairo.Internal -- due to GHC export bug in 7.4 + +import Diagrams.Builder + +import System.Directory (copyFile) +import qualified System.FilePath as FP + +import System.Console.CmdArgs + +compileExample :: Build -> IO () +compileExample (Build{..}) = do + let fmt = case FP.takeExtension outFile of + ".png" -> PNG + ".svg" -> SVG + ".ps" -> PS + ".pdf" -> PDF + _ -> PNG + + f <- readFile srcFile + + res <- buildDiagram + Cairo + zeroV + (CairoOptions outFile (mkSizeSpec width height) fmt) + [f] + expr + [] + [ "Diagrams.Backend.Cairo" ] + (hashedRegenerate + (\hash opts -> opts { cairoFileName = mkFile hash }) + dir + ) + case res of + ParseErr err -> putStrLn ("Parse error in " ++ srcFile) >> putStrLn err + InterpErr ierr -> putStrLn ("Error while compiling " ++ srcFile) >> + putStrLn (ppInterpError ierr) + Skipped hash -> copyFile (mkFile hash) outFile + OK hash (act,_) -> act >> copyFile (mkFile hash) outFile + where + mkFile base = dir FP. base FP.<.> "png" + +data Build = Build { width :: Maybe Double + , height :: Maybe Double + , srcFile :: String + , expr :: String + , outFile :: String + , dir :: String + } + deriving (Typeable, Data) + +build :: Build +build = Build { width = def &= typ "INT" + , height = def &= typ "INT" + , srcFile = "" &= argPos 0 &= typFile + , expr = "dia" + &= typ "EXPRESSION" + &= help "Expression to render (default: \"dia\")" + , outFile = "out.png" &= typFile &= help "Output file (default: \"out.png\")" + , dir = "diagrams" + &= typDir + &= help "Directory in which to store rendered diagrams by hash (default: \"diagrams\")" + } + &= summary "The diagrams-builder-cairo program, for dynamically rendering diagrams using the cairo backend. Give it a source file and an expression to render (which may refer to things declared in the source file), and it outputs an image, using hashing to avoid rerendering images unnecessarily." + &= program "diagrams-builder-cairo" + +main :: IO () +main = do + opts <- cmdArgs build + compileExample opts