diagrams-haddock (empty) → 0.1.0.0
raw patch · 9 files changed
+1245/−0 lines, 9 filesdep +Cabaldep +QuickCheckdep +basebuild-type:Customsetup-changed
Dependencies added: Cabal, QuickCheck, base, blaze-svg, bytestring, cautious-file, cmdargs, containers, cpphs, diagrams-builder, diagrams-haddock, diagrams-lib, diagrams-svg, directory, filepath, haskell-src-exts, lens, mtl, parsec, split, strict, test-framework, test-framework-quickcheck2, text, uniplate, vector-space
Files
- CHANGES.md +4/−0
- LICENSE +33/−0
- README.md +281/−0
- Setup.hs +27/−0
- diagrams-haddock.cabal +84/−0
- diagrams/greenCircle.svg +4/−0
- src/Diagrams/Haddock.hs +545/−0
- test/Tests.hs +112/−0
- tools/diagrams-haddock.hs +155/−0
+ CHANGES.md view
@@ -0,0 +1,4 @@+0.1.0.0 (23 March 2013)+-----------------------++Initial release!
+ LICENSE view
@@ -0,0 +1,33 @@+Copyright (c) 2013, diagrams-haddock team:++Ryan Yates+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.
+ README.md view
@@ -0,0 +1,281 @@+# diagrams-haddock++`diagrams-haddock` is a preprocessor which allows embedding images+generated using the [diagrams+framework](http://projects.haskell.org/diagrams/) within Haddock+documentation. The code to generate images is embedded directly+within the source file itself (and the code can be included in the+Haddock output or not, as you wish). `diagrams-haddock` takes care of+generating SVG images and linking them into the Haddock output.++## Installing++Just `cabal install diagrams-haddock`. If you have any trouble, ask+in the `#diagrams` freenode IRC channel, or file a ticket on the+[bug tracker](http://github.com/diagrams/diagrams-haddock/issues).++## On the design of `diagrams-haddock`++Before getting into the details of using `diagrams-haddock`, it should+be noted that `diagrams-haddock` has been carefully designed so that+*you only have to maintain a single copy of your source files*. In+particular, you do *not* have to maintain one copy of your source+files with embedded diagrams code and another copy where the diagrams+code has been replaced by images. If you find yourself scratching+your head over the quirky ways that `diagrams-haddock` works, now you+will know why.++## An important caveat++`diagrams-haddock` modifies files *in place*! While we have worked+hard to ensure that it cannot make catastrophic changes to your files,+you would be wise to **only run `diagrams-haddock` on files under+version control** so you can easily examine and (if necessary) undo+the changes it makes. (Of course, being a conscientious developer,+you would never work with source files not under version control,+right?)++## Adding diagrams to source files++Haddock supports inline links to images with the syntax+`<<URL>>`. To indicate an image which should be automatically+generated from some diagrams code, use the special syntax+`<<URL#diagram=name&key1=val1&key2=val2&...>>`. The URL will be+automatically filled in by `diagrams-haddock`, so when you first+create an inline image placeholder you can put any arbitrary text in+its place. For example, you might write++ <<dummy#diagram=mySquare&width=200&height=300>>++indicating an image which should be generated using the definition of+`mySquare`, with a maximum width of 200 and maximum height of 300.+(Incidentally, this syntax is used because everything following the+`#` symbol will be ignored by browsers.)++Continuing with the above example, you must also provide a definition+of `mySquare`. You must provide it in a code block, which must be set+off by bird tracks (that is, greater-than symbols followed by at least+one space). For example,++``` haskell+-- > mySquare = square 1 # fc blue # myTransf+-- > myTransf = rotateBy (1/27)+```++You can choose to have the code block included in the Haddock output+or not, simply by putting it in a Haddock comment or not. Note that+the code block defining `mySquare` can be anywhere in the same file;+it does not have to be right before or right after the diagram URL+referencing it.++## Code block dependency analysis++`diagrams-haddock` does a simple dependency analysis to determine+which code blocks should be in scope while compiling each diagram.+First, it locates a code block containing a binding for the requested+diagram name. Then, it pulls in any code blocks containing bindings+for identifiers referenced by this code block, and so on transitively.+(Note that this analysis is overly simplistic and does not take things+like shadowing into account; this may sometimes cause additional code+blocks to be included which would not be included with a more careful+analysis.)++This has a few implications. First, code blocks containing irrelevant+bindings will not be considered. It is common to have code blocks+which are intended simply to show some example code---they may not+even be valid Haskell. However, as long as such code blocks do not+contain any bindings of names used by a diagram, they will be ignored.+For example:++``` haskell+-- The algorithm works by doing the equivalent of+--+-- > rep = uncurry replicate+-- >+-- > algo = map rep . zip [1..]+--+-- as illustrated below:+--+-- <<dummy#diagram=algoIllustration&width=400>>+--+-- > algoIllustration = ...+```++The first code block shown above (beginning `rep = ...`) contains some+bindings, but none of those bindings are referenced by any diagram+URLs, so the code block is ignored.++Another convenient implication is that supporting code can be put in+separate code blocks and even shared between diagrams. For example:++``` haskell+-- > makeitblue d = d # fc blue # lc blue+--+-- Here is a blue circle:+--+-- <<dummy#diagram=blueC&width=200>>+--+-- > blueC = circle 1 # makeitblue+--+-- And here is a blue square:+--+-- <<dummy#diagram=blueS&width=200>>+--+-- > blueS = square 1 # makeitblue+```++This also means that diagrams are recompiled only when necessary. For+example, if the definition of `blueC` is changed, only `blueC` will be+recompiled. If the definition of `makeitblue` is changed, both+`blueC` and `blueS` will be recompiled.++## Invoking diagrams-haddock++Invoking the `diagrams-haddock` tool is simple: just give it a+list of targets, like so:++```+diagrams-haddock foo.hs baz/bar.lhs ~/src/some-cabal-directory+```++* For file targets, `diagrams-haddock` simply processes the given file.++* Directory targets are assumed to contain Cabal packages, which+ themselves contain a library. `diagrams-haddock` then finds and+ processes the source files corresponding to all modules exported by+ the library. (Note that `diagrams-haddock` does not currently run on+ unexported modules or on the source code for executables, but if you+ have a use case for either, just file a [feature+ request](https://github.com/diagrams/diagrams-haddock/issues); they+ shouldn't be too hard to add.)++Also, if you simply invoke `diagrams-haddock` with no targets, it will+process the Cabal package in the current directory.++`diagrams-haddock` also takes a few command-line options which can be+used to customize its behavior:++* `-c`, `--cachedir`: When diagrams are compiled, their source code is+ hashed and the output image stored in a file like `068fe.......342.svg`,+ with the value of the hash as the name of the file. This way, if+ the source code for a diagram has not changed in between invocations+ of `diagrams-haddock`, it does not need to be recompiled. This+ option lets you specify the directory where such cached SVG files+ should be stored; the default is `.diagrams-cache`.++* `-o`, `--outputdir`: This is the directory into which the final+ output images will be produced. The default is `diagrams`.++* `-i`, `--includedirs`: `diagrams-haddock` does its best to process+ files with CPP directives, even extracting information about where+ to find `#include`s from the `.cabal` file, but sometimes it might+ need a little help. This option lets you specify additional+ directories in which `diagrams-haddock` should look when searching+ for `#include`d files.++* `--cppdefines`: likewise, this option allows you to specify+ additional names that should be `#define`d when CPP is run.++* `-q`, `--quiet`: `diagrams-haddock` normally prints some logging+ information to indicate what it is doing; this option silences the+ output.++## Workflow and Cabal setup++The recommended workflow for using `diagrams-haddock` is as follows:++1. Include inline diagrams code and URLs in your source code.+2. Run `diagrams-haddock`.+3. Commit the resulting URL changes and produced SVG files.+4. Arrange to have the SVG files installed along with your package's+ Haddock documentation (more on this below).++The point is that consumers of your library (such as Hackage) do not+need to have `diagrams-haddock` installed in order to build your+documentation.++The generated SVG files need to be copied alongside the generated+Haddock documentation. There are two good ways to accomplish this:++1. The `cabal` tool has recently acquired an `extra-html-files` field+ (see https://github.com/haskell/cabal/pull/1182), specifying files+ which should be copied in alongside generated Haddock+ documentation. So you could simply write something like++ ```+ extra-html-files: diagrams/*.svg+ ```++ in your `.cabal` file. Unfortunately, it will still be a while+ until this feature makes its way into a new release of `cabal`,+ and yet longer before you can be sure that most people who may+ want to build your package's documentation have the new version.+ So this is currently a good option only if you have the HEAD+ version of `cabal` and don't care about others being able to+ build your documentation. However, in the not-too-distant future+ this will become the best option.++2. In the meantime, it is possible to take advantage of `cabal`'s+ system of user hooks to manually copy the images right after the+ Haddock documentation is generated. Add something like++ ```+ build-type: Custom+ extra-source-files: diagrams/*+ ```++ to your `.cabal` file, and then put something like the following in your+ `Setup.hs`:++ ``` haskell+ import Data.List (isSuffixOf)+ import Distribution.Simple+ import Distribution.Simple.Setup (Flag (..), HaddockFlags,+ haddockDistPref)+ import Distribution.Simple.Utils (copyFiles)+ import Distribution.Text (display)+ import Distribution.Verbosity (normal)+ import System.Directory (getDirectoryContents)+ import System.FilePath ((</>))++ -- Ugly hack, logic copied from Distribution.Simple.Haddock+ haddockOutputDir :: Package pkg => HaddockFlags -> pkg -> FilePath+ haddockOutputDir flags pkg = destDir+ where+ baseDir = case haddockDistPref flags of+ NoFlag -> "."+ Flag x -> x+ destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)++ diagramsDir = "diagrams"++ main :: IO ()+ main = defaultMainWithHooks simpleUserHooks+ { postHaddock = \args flags pkg lbi -> do+ dias <- filter ("svg" `isSuffixOf`) `fmap` getDirectoryContents diagramsDir+ copyFiles normal (haddockOutputDir flags pkg)+ (map (\d -> ("", diagramsDir </> d)) dias)+ postHaddock simpleUserHooks args flags pkg lbi+ }+ ```++ It may not be pretty, but it works!++## File encodings++For now, `diagrams-haddock` assumes that all `.hs` and `.lhs` files+are encoded using UTF-8. If you would like to use it with source+files stored using some other encoding, feel free to [file a feature+request](https://github.com/diagrams/diagrams-haddock/issues).++## The diagrams-haddock library++For most use cases, simply using the `diagrams-haddock` executable+should get you what you want. Note, however, that the internals are+also exposed as a library, making it possible to do all sorts of crazy+stuff you might dream up. Let us know what you do with it!++## Reporting bugs++Please report any bugs, feature requests, *etc.*, on the [github issue+tracker](https://github.com/diagrams/diagrams-haddock/issues).
+ Setup.hs view
@@ -0,0 +1,27 @@+import Data.List (isSuffixOf)+import Distribution.Simple+import Distribution.Simple.Setup (Flag (..), HaddockFlags,+ haddockDistPref)+import Distribution.Simple.Utils (copyFiles)+import Distribution.Text (display)+import Distribution.Verbosity (normal)+import System.Directory (getDirectoryContents)+import System.FilePath ((</>))++-- Ugly hack, logic copied from Distribution.Simple.Haddock+haddockOutputDir :: Package pkg => HaddockFlags -> pkg -> FilePath+haddockOutputDir flags pkg = destDir+ where+ baseDir = case haddockDistPref flags of+ NoFlag -> "."+ Flag x -> x+ destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+ { postHaddock = \args flags pkg lbi -> do+ dias <- filter ("svg" `isSuffixOf`) `fmap` getDirectoryContents "diagrams"+ copyFiles normal (haddockOutputDir flags pkg)+ (map (\d -> ("", "diagrams" </> d)) dias)+ postHaddock simpleUserHooks args flags pkg lbi+ }
+ diagrams-haddock.cabal view
@@ -0,0 +1,84 @@+name: diagrams-haddock+version: 0.1.0.0+synopsis: Preprocessor for embedding diagrams in Haddock documentation+description: diagrams-haddock is a tool for compiling embedded inline+ diagrams code in Haddock documentation, for an+ easy way to spice up your documentation with+ diagrams. Just create some diagrams code using+ special markup, run diagrams-haddock, and ensure+ the resulting image files are installed along+ with your documentation. For complete+ documentation and examples, see+ <https://github.com/diagrams/diagrams-haddock/blob/master/README.md>.+ .+ For a good example of a package making use of+ diagrams-haddock, see the diagrams-contrib+ package+ (<http://hackage.haskell.org/package/diagrams%2Dcontrib>).+homepage: http://projects.haskell.org/diagrams/+license: BSD3+license-file: LICENSE+author: Brent Yorgey+maintainer: diagrams-discuss@googlegroups.com+bug-reports: https://github.com/diagrams/diagrams-haddock/issues+category: Graphics+build-type: Custom+cabal-version: >=1.10+extra-source-files: README.md, CHANGES.md, diagrams/*.svg++Source-repository head+ type: git+ location: git://github.com/diagrams/diagrams-haddock.git++library+ exposed-modules: Diagrams.Haddock+ build-depends: base >= 4.4 && < 4.7,+ filepath,+ directory,+ mtl >= 2.0 && < 2.2,+ containers >= 0.4 && < 0.6,+ split >= 0.2 && < 0.3,+ bytestring >= 0.9 && < 0.11,+ strict >= 0.3 && < 0.4,+ parsec >= 3,+ haskell-src-exts >= 1.13.5 && < 1.14,+ blaze-svg >= 0.3 && < 0.4,+ diagrams-builder >= 0.3 && < 0.5,+ diagrams-lib >= 0.6 && < 0.7,+ diagrams-svg >= 0.6 && < 0.7,+ vector-space >= 0.8 && < 0.9,+ lens >= 3.8 && < 3.9,+ cpphs >= 1.15,+ cautious-file >= 1.0 && < 1.1,+ uniplate >= 1.6 && < 1.7,+ text >= 0.11 && < 0.12+ hs-source-dirs: src+ other-extensions: TemplateHaskell+ default-language: Haskell2010++Executable diagrams-haddock+ main-is: diagrams-haddock.hs+ build-depends: base,+ directory,+ filepath,+ diagrams-haddock,+ cmdargs >= 0.8 && < 0.11,+ Cabal >= 1.14 && < 1.18,+ cpphs >= 1.15+ hs-source-dirs: tools+ default-language: Haskell2010++Test-suite diagrams-haddock-tests+ type: exitcode-stdio-1.0+ main-is: Tests.hs+ build-depends: base,+ containers >= 0.4 && < 0.6,+ QuickCheck >= 2.4 && < 2.6,+ test-framework >= 0.8 && < 0.9,+ test-framework-quickcheck2 >= 0.3 && < 0.4,+ parsec >= 3,+ haskell-src-exts >= 1.13 && < 1.14,+ lens >= 3.8 && < 3.9,+ diagrams-haddock+ hs-source-dirs: test+ default-language: Haskell2010
+ diagrams/greenCircle.svg view
@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" width="200.0" height="199.99999999999997" font-size="1" viewBox="0 0 200 200"><g><g transform="matrix(90.9090909090909,0.0,0.0,90.9090909090909,99.99999999999999,100.0)"><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(0,128,0)" fill-opacity="1.0" stroke-width="1.0e-2" font-size="1.0em"><path d="M 1.0,0.0 c 0.0,-0.5522847498307935 -0.44771525016920644,-1.0 -0.9999999999999998 -1.0c -0.5522847498307935,-3.3817687554908895e-17 -1.0,0.4477152501692064 -1.0 0.9999999999999997c -6.763537510981779e-17,0.5522847498307935 0.4477152501692063,1.0 0.9999999999999996 1.0c 0.5522847498307935,1.0145306266472669e-16 1.0,-0.44771525016920627 1.0 -0.9999999999999994Z" /></g></g></g></svg>
+ src/Diagrams/Haddock.hs view
@@ -0,0 +1,545 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : Diagrams.Haddock+-- Copyright : (c) 2013 diagrams-haddock team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- Include inline diagrams code in Haddock documentation! For+-- example, here is a green circle:+--+-- <<diagrams/greenCircle.svg#diagram=greenCircle&width=200>>+--+-- which was literally produced by this code:+--+-- > greenCircle = circle 1+-- > # fc green # pad 1.1+--+-- For a much better example of the use of diagrams-haddock, see the+-- diagrams-contrib package: <http://hackage.haskell.org/package/diagrams%2Dcontrib>.+--+-- For complete documentation and examples, see+-- <https://github.com/diagrams/diagrams-haddock/blob/master/README.md>.+-----------------------------------------------------------------------------+module Diagrams.Haddock+ ( -- * Diagram URLs+ -- $urls++ DiagramURL(..)+ , displayDiagramURL+ , parseDiagramURL+ , parseKeyValPair+ , maybeParseDiagramURL++ , parseDiagramURLs+ , displayDiagramURLs++ -- * Comments+ -- $comments++ , getDiagramNames+ , coalesceComments++ -- * Code blocks+ -- $codeblocks++ , CodeBlock(..)+ , codeBlockCode, codeBlockIdents, codeBlockBindings+ , makeCodeBlock+ , collectBindings+ , extractCodeBlocks+ , parseCodeBlocks+ , transitiveClosure++ -- * Diagram compilation+ -- $diagrams++ , compileDiagram+ , compileDiagrams+ , processHaddockDiagrams+ , processHaddockDiagrams'++ -- * Utilities++ , showParseFailure+ , CollectErrors(..)+ , failWith+ , runCE++ ) where++import Control.Applicative hiding (many, (<|>))+import Control.Arrow (first, (&&&), (***))+import Control.Lens hiding ((<.>))+import Control.Monad.Writer+import qualified Data.ByteString.Lazy as BS+import Data.Char (isSpace)+import Data.Either (lefts, rights)+import Data.Function (on)+import Data.Generics.Uniplate.Data (universeBi)+import Data.List (groupBy, intercalate,+ isPrefixOf, partition)+import Data.List.Split (dropBlanks, dropDelims, split,+ whenElt)+import qualified Data.Map as M+import Data.Maybe (catMaybes, mapMaybe)+import qualified Data.Set as S+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.Encoding as T+import Data.VectorSpace (zeroV)+import Language.Haskell.Exts.Annotated hiding (loc)+import qualified Language.Haskell.Exts.Annotated as HSE+import Language.Preprocessor.Cpphs+import System.Directory (copyFile,+ createDirectoryIfMissing,+ doesFileExist)+import System.FilePath ((<.>), (</>))+import qualified System.IO as IO+import qualified System.IO.Cautious as Cautiously+import qualified System.IO.Strict as Strict+import Text.Blaze.Svg.Renderer.Utf8 (renderSvg)+import Text.Parsec+import qualified Text.Parsec as P+import Text.Parsec.String++import Diagrams.Backend.SVG (Options (..), SVG (..))+import Diagrams.Builder (BuildResult (..),+ buildDiagram,+ hashedRegenerate,+ ppInterpError)+import Diagrams.TwoD.Size (mkSizeSpec)++------------------------------------------------------------+-- Utilities+------------------------------------------------------------++showParseFailure :: SrcLoc -> String -> String+showParseFailure loc err = unlines [ prettyPrint loc, err ]++newtype CollectErrors a = CE { unCE :: Writer [String] a }+ deriving (Functor, Applicative, Monad, MonadWriter [String])++failWith :: String -> CollectErrors (Maybe a)+failWith err = tell [err] >> return Nothing++runCE :: CollectErrors a -> (a, [String])+runCE = runWriter . unCE++------------------------------------------------------------+-- Diagram URLs+------------------------------------------------------------++-- $urls+-- Haddock supports inline links to images with the syntax+-- @\<\<URL\>\>@. To indicate an image which should be automatically+-- generated from some diagrams code, we use the special syntax+-- @\<\<URL#diagram=name&key1=val1&key2=val2&...\>\>@. The point is+-- that everything following the @#@ will be ignored by browsers, but+-- we can use it to indicate to diagrams-haddock the name of the+-- diagram to be rendered along with options such as size.++-- | An abstract representation of inline Haddock image URLs with+-- diagrams tags, like @\<\<URL#diagram=name&width=100\>\>@.+data DiagramURL = DiagramURL+ { _diagramURL :: String+ , _diagramName :: String+ , _diagramOpts :: M.Map String String+ }+ deriving (Show, Eq)++makeLenses ''DiagramURL++-- | Display a diagram URL in the format @\<\<URL#diagram=name&key=val&...\>\>@.+displayDiagramURL :: DiagramURL -> String+displayDiagramURL d = "<<" ++ d ^. diagramURL ++ "#" ++ opts ++ ">>"+ where+ opts = intercalate "&"+ . map displayOpt+ . (("diagram", d ^. diagramName) :)+ . M.assocs+ $ d ^. diagramOpts+ displayOpt (k,v) = k ++ "=" ++ v++-- | Parse things of the form @\<\<URL#diagram=name&key=val&...\>\>@.+parseDiagramURL :: Parser DiagramURL+parseDiagramURL =+ DiagramURL+ <$> (string "<<" *> many1 (noneOf "#>"))+ <*> (char '#' *> string "diagram=" *> many1 (noneOf "&>"))+ <*> ((M.fromList <$> many parseKeyValPair) <* string ">>")++-- | Parse a key/value pair of the form @&key=val@.+parseKeyValPair :: Parser (String,String)+parseKeyValPair =+ char '&' *>+ ((,) <$> (many1 (noneOf "&>=") <* char '=') <*> many1 (noneOf "&>="))++-- | Parse a diagram URL /or/ a single character which is not the+-- start of a diagram URL.+maybeParseDiagramURL :: Parser (Either Char DiagramURL)+maybeParseDiagramURL =+ Right <$> try parseDiagramURL+ <|> Left <$> anyChar++-- | Decompose a string into a parsed form with explicitly represented+-- diagram URLs interspersed with other content.+parseDiagramURLs :: Parser [Either String DiagramURL]+parseDiagramURLs = condenseLefts <$> many maybeParseDiagramURL+ where+ condenseLefts :: [Either a b] -> [Either [a] b]+ condenseLefts [] = []+ condenseLefts (Right a : xs) = Right a : condenseLefts xs+ condenseLefts xs = Left (lefts ls) : condenseLefts xs'+ where (ls,xs') = span isLeft xs+ isLeft (Left {}) = True+ isLeft _ = False++-- | Serialize a parsed comment with diagram URLs back into a String.+displayDiagramURLs :: [Either String DiagramURL] -> String+displayDiagramURLs = concatMap (either id displayDiagramURL)++------------------------------------------------------------+-- Comments+------------------------------------------------------------++-- $comments+-- A few miscellaneous functions for dealing with comments.++-- | Get the names of all diagrams referenced from diagram URLs in the+-- given comment.+getDiagramNames :: Comment -> S.Set String+getDiagramNames (Comment _ _ s) =+ case P.parse parseDiagramURLs "" s of+ Left _ -> error "This case can never happen; see prop_parseDiagramURLs_succeeds"+ Right urls -> S.fromList . map (view diagramName) . rights $ urls++-- | Given a series of comments, return a list of their contents,+-- coalescing blocks of adjacent single-line comments into one+-- String. Each string will be paired with the number of the line+-- on which it begins.+coalesceComments :: [Comment] -> [(String, Int)]+coalesceComments+ = map (unlines . map getComment &&& commentLine . head)++ -- discard no longer needed numbers+ . map (map fst)++ -- group consecutive runs+ . concatMap (groupBy ((==) `on` snd))++ -- subtract consecutive numbers so runs show up as repeats+ -- e.g. L1, L2, L3, L6, L7, L9 --> 0,0,0,2,2,3+ . map (zipWith (\i c -> (c, commentLine c - i)) [1..])++ -- explode out each multi-line comment into its own singleton list,+ -- which will be unaffected by the above shenanigans+ . concatMap (\xs -> if isMultiLine (head xs) then map (:[]) xs else [xs])++ -- group multi + single line comments together+ . groupBy ((==) `on` isMultiLine)++ where+ isMultiLine (Comment b _ _) = b+ getComment (Comment _ _ c) = c+ commentLine (Comment _ s _) = srcSpanStartLine s++ -- Argh, I really wish the split package supported splitting on a+ -- predicate over adjacent elements! That would make the above+ -- soooo much easier.++------------------------------------------------------------+-- Code blocks+------------------------------------------------------------++-- $codeblocks+-- A code block represents some portion of a comment set off by bird+-- tracks. We also collect a list of the names bound in each code+-- block, in order to decide which code blocks contain expressions+-- representing diagrams that are to be rendered.++-- | A @CodeBlock@ represents a portion of a comment which is a valid+-- code block (set off by > bird tracks). It also caches the list+-- of bindings present in the code block.+data CodeBlock+ = CodeBlock+ { _codeBlockCode :: String+ , _codeBlockIdents :: S.Set String+ , _codeBlockBindings :: S.Set String+ }+ deriving (Show, Eq)++makeLenses ''CodeBlock++-- | Given a @String@ representing a code block, /i.e./ valid Haskell+-- code with any bird tracks already stripped off, along with its+-- beginning line number (and the name of the file from which it was+-- taken), attempt to parse it, extract the list of bindings+-- present, and construct a 'CodeBlock' value.+makeCodeBlock :: FilePath -> (String,Int) -> CollectErrors (Maybe CodeBlock)+makeCodeBlock file (s,l) =+ case HSE.parseFileContentsWithMode parseMode s of+ ParseOk m -> return . Just $ CodeBlock s+ (collectIdents m)+ (collectBindings m)+ ParseFailed loc err -> failWith . unlines $+ [ file ++ ": " ++ show l ++ ": Warning: could not parse code block:" ]+ +++ showBlock s+ +++ [ "Error was:" ]+ +++ (indent 2 . lines $ showParseFailure loc err)+ where+ parseMode = defaultParseMode+ { fixities = Nothing+ , extensions = MultiParamTypeClasses : haskell2010+ }+ indent n = map (replicate n ' ' ++)+ showBlock b+ | length ls > 5 = indent 2 (take 4 ls ++ ["..."])+ | otherwise = indent 2 ls+ where ls = lines b++-- | Collect the list of names bound in a module.+collectBindings :: Module l -> S.Set String+collectBindings (Module _ _ _ _ decls) = S.fromList $ mapMaybe getBinding decls+collectBindings _ = S.empty++getBinding :: Decl l -> Maybe String+getBinding (FunBind _ []) = Nothing+getBinding (FunBind _ (Match _ nm _ _ _ : _)) = Just $ getName nm+getBinding (PatBind _ (PVar _ nm) _ _ _) = Just $ getName nm+getBinding _ = Nothing++getName :: Name l -> String+getName (Ident _ s) = s+getName (Symbol _ s) = s++getQName :: QName l -> Maybe String+getQName (Qual _ _ n) = Just $ getName n+getQName (UnQual _ n) = Just $ getName n+getQName _ = Nothing++-- | Collect the list of referenced identifiers in a module.+collectIdents :: Module SrcSpanInfo -> S.Set String+collectIdents m = S.fromList . catMaybes $+ [ getQName n+ | (Var _ n :: Exp SrcSpanInfo) <- universeBi m+ ]++-- | From a @String@ representing a comment (along with its beginning+-- line number, and the name of the file it came from, for error+-- reporting purposes), extract all the code blocks (consecutive+-- lines beginning with bird tracks), and error messages for code+-- blocks that fail to parse.+extractCodeBlocks :: FilePath -> (String,Int) -> CollectErrors [CodeBlock]+extractCodeBlocks file (s,l)+ = fmap catMaybes+ . mapM (makeCodeBlock file . (unlines***head) . unzip . (map.first) (drop 2 . dropWhile isSpace))+ . (split . dropBlanks . dropDelims $ whenElt (not . isBird . fst))+ . flip zip [l ..]+ . lines+ $ s+ where+ isBird = ((||) <$> (">"==) <*> ("> " `isPrefixOf`)) . dropWhile isSpace++-- | Take the contents of a Haskell source file (and the name of the+-- file, for error reporting purposes), and extract all the code+-- blocks, as well as the referenced diagram names.+parseCodeBlocks :: FilePath -> String -> CollectErrors (Maybe ([CodeBlock], S.Set String))+parseCodeBlocks file src =+ case HSE.parseFileContentsWithComments parseMode src of+ ParseFailed loc err -> failWith $ showParseFailure loc err+ ParseOk (_, cs) -> do+ blocks <- fmap concat+ . mapM (extractCodeBlocks file)+ . coalesceComments+ $ cs+ let diaNames = S.unions . map getDiagramNames $ cs++ return . Just $ (blocks, diaNames)+ where+ parseMode = defaultParseMode+ { fixities = Nothing+ , parseFilename = file+ , extensions = MultiParamTypeClasses : haskell2010+ }++-- | Given an identifier and a list of CodeBlocks, filter the list of+-- CodeBlocks to the transitive closure of the "depends-on"+-- relation, /i.e./ only blocks which bind identifiers referenced in+-- blocks ultimately needed by the block which defines the desired+-- identifier.+transitiveClosure :: String -> [CodeBlock] -> [CodeBlock]+transitiveClosure ident blocks = tc [ident] blocks+ where+ tc _ [] = []+ tc [] _ = []+ tc (i:is) blocks =+ let (ins,outs) = partition (\cb -> i `S.member` (cb ^. codeBlockBindings)) blocks+ in ins ++ tc (is ++ concatMap (S.toList . view codeBlockIdents) ins) outs++------------------------------------------------------------+-- Diagrams+------------------------------------------------------------++-- $diagrams+-- This section contains all the functions which actually interface+-- with diagrams-builder in order to compile diagrams referenced from+-- URLs.++-- | Given a directory for cached diagrams and a directory for+-- outputting final diagrams, and all the relevant code blocks,+-- compile the diagram referenced by a single URL, returning a new+-- URL updated to point to the location of the generated diagram.+-- Also return a @Bool@ indicating whether the URL changed.+--+-- In particular, the diagram will be output to @outDir/name.svg@,+-- where @outDir@ is the second argument to @compileDiagram@, and+-- @name@ is the name of the diagram. The updated URL will also+-- refer to @outDir/name.svg@, under the assumption that @outDir@+-- will be copied into the Haddock output directory. (For+-- information on how to make this copying happen, see the README:+-- <https://github.com/diagrams/diagrams-haddock/blob/master/README.md>.)+-- If for some reason you would like this scheme to be more+-- flexible/configurable, feel free to file a feature request.+compileDiagram :: Bool -- ^ @True@ = quiet+ -> FilePath -- ^ cache directory+ -> FilePath -- ^ output directory+ -> S.Set String -- ^ diagrams referenced from URLs+ -> [CodeBlock] -> DiagramURL -> IO (DiagramURL, Bool)+compileDiagram quiet cacheDir outputDir ds code url+ -- See https://github.com/diagrams/diagrams-haddock/issues/7 .+ | (url ^. diagramName) `S.notMember` ds = return (url, False)++ -- The normal case.+ | otherwise = do+ createDirectoryIfMissing True outputDir+ createDirectoryIfMissing True cacheDir++ let outFile = outputDir </> (url ^. diagramName) <.> "svg"++ w = read <$> M.lookup "width" (url ^. diagramOpts)+ h = read <$> M.lookup "height" (url ^. diagramOpts)++ oldURL = (url, False)+ newURL = (url & diagramURL .~ outFile, outFile /= url^.diagramURL)++ neededCode = transitiveClosure (url ^. diagramName) code++ logStr $ (url ^. diagramName) ++ "..."+ IO.hFlush IO.stdout++ res <- buildDiagram+ SVG+ zeroV+ (SVGOptions (mkSizeSpec w h))+ (map (view codeBlockCode) neededCode)+ (url ^. diagramName)+ []+ [ "Diagrams.Backend.SVG" ]+ (hashedRegenerate (\_ opts -> opts) cacheDir)++ case res of+ -- XXX incorporate these into error reporting framework instead of printing+ ParseErr err -> do+ putStrLn ("Parse error:")+ putStrLn err+ return oldURL+ InterpErr ierr -> do+ putStrLn ("Interpreter error:")+ putStrLn (ppInterpError ierr)+ return oldURL+ Skipped hash -> do+ copyFile (mkCached hash) outFile+ logStrLn ""+ return newURL+ OK hash svg -> do+ let cached = mkCached hash+ BS.writeFile cached (renderSvg svg)+ copyFile cached outFile+ logStrLn "compiled."+ return newURL++ where+ mkCached base = cacheDir </> base <.> "svg"+ logStr = when (not quiet) . putStr+ logStrLn = when (not quiet) . putStrLn++-- | Compile all the diagrams referenced in an entire module.+compileDiagrams :: Bool -- ^ @True@ = quiet+ -> FilePath -- ^ cache directory+ -> FilePath -- ^ output directory+ -> S.Set String -- ^ diagram names referenced from URLs+ -> [CodeBlock]+ -> [Either String DiagramURL] -> IO ([Either String DiagramURL], Bool)+compileDiagrams quiet cacheDir outputDir ds cs urls = do+ urls' <- urls & (traverse . _Right)+ %%~ compileDiagram quiet cacheDir outputDir ds cs+ let changed = orOf (traverse . _Right . _2) urls'+ return (urls' & (traverse . _Right) %~ fst, changed)++-- | Read a file, compile all the referenced diagrams, and update all+-- the diagram URLs to refer to the proper image files. Note, this+-- /overwrites/ the file, so it's recommended to only do this on+-- files that are under version control, so you can compare the two+-- versions and roll back if 'processHaddockDiagrams' does something+-- horrible.+--+-- Returns a list of warnings and/or errors.+processHaddockDiagrams+ :: Bool -- ^ quiet+ -> FilePath -- ^ cache directory+ -> FilePath -- ^ output directory+ -> FilePath -- ^ file to be processed+ -> IO [String]+processHaddockDiagrams = processHaddockDiagrams' opts+ where+ opts = defaultCpphsOptions+ { boolopts = defaultBoolOptions { hashline = False } }++-- | Version of 'processHaddockDiagrams' that takes options for @cpphs@.+processHaddockDiagrams'+ :: CpphsOptions -- ^ Options for cpphs+ -> Bool -- ^ quiet+ -> FilePath -- ^ cache directory+ -> FilePath -- ^ output directory+ -> FilePath -- ^ file to be processed+ -> IO [String]+processHaddockDiagrams' opts quiet cacheDir outputDir file = do+ e <- doesFileExist file+ case e of+ False -> return ["Error: " ++ file ++ " not found."]+ True -> do+ -- always assume UTF-8, to make our lives simpler!+ h <- IO.openFile file IO.ReadMode+ IO.hSetEncoding h IO.utf8+ src <- Strict.hGetContents h+ r <- go src+ case r of+ (Nothing, msgs) -> return msgs+ (Just (cs, ds), msgs) ->+ case P.parse parseDiagramURLs "" src of+ Left _ ->+ error "This case can never happen; see prop_parseDiagramURLs_succeeds"+ Right urls -> do+ (urls', changed) <- compileDiagrams quiet cacheDir outputDir ds cs urls+ let src' = displayDiagramURLs urls'++ -- See https://github.com/diagrams/diagrams-haddock/issues/8:+ -- Cautiously.writeFile truncates chars to 8 bits. So+ -- we do the encoding to UTF-8 ourselves and then call+ -- writeFileL.+ when changed $ Cautiously.writeFileL file (T.encodeUtf8 . T.pack $ src')+ return msgs+ where+ go src =+ case runCE (parseCodeBlocks file src) of+ r@(Nothing, msgs) -> if any (("Parse error: #" `elem`) . lines) msgs+ then runCpp src >>= return . runCE . parseCodeBlocks file+ else return r+ r -> return r+ runCpp s = runCpphs opts file s
+ test/Tests.hs view
@@ -0,0 +1,112 @@+module Main where++import Control.Applicative+import Control.Lens (view)+import Data.Either (rights)+import Data.List ((\\))+import qualified Data.Map as M+import qualified Data.Set as S+import Language.Haskell.Exts.Annotated+import Test.Framework (defaultMain)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck+import qualified Text.Parsec as P++import Diagrams.Haddock++newtype EString = EString { getEString :: String }+ deriving (Eq, Show)+instance Arbitrary EString where+ arbitrary = do+ NonEmpty s <- arbitrary+ if any (`elem` "#<>&=") s+ then arbitrary+ else return (EString s)++both :: (a -> b) -> (a, a) -> (b, b)+both g (x,y) = (g x, g y)++instance Arbitrary DiagramURL where+ arbitrary = DiagramURL <$> s <*> s <*> opts+ where+ s = getEString <$> arbitrary+ opts = (M.fromList . (map . both) getEString) <$> arbitrary++instance Arbitrary SrcSpan where+ arbitrary = do+ NonEmpty fileName <- arbitrary+ Positive startLine <- arbitrary+ NonNegative startCol <- arbitrary+ NonNegative numLines <- arbitrary+ NonNegative numCols <- arbitrary++ return $ SrcSpan fileName startLine startCol (startLine + numLines) (startCol + numCols)++instance Arbitrary Comment where+ arbitrary = Comment <$> arbitrary <*> arbitrary <*> arbitrary++prop_parseDisplay :: DiagramURL -> Bool+prop_parseDisplay d+ = case P.parse parseDiagramURL "" (displayDiagramURL d) of+ Left _ -> False+ Right d' -> d == d'++prop_parseDisplayMany :: [Either EString DiagramURL] -> Bool+prop_parseDisplayMany c+ = case P.parse parseDiagramURLs "" (displayDiagramURLs c') of+ Left _ -> False+ Right cp -> rights c' == rights cp+ && displayDiagramURLs c' == displayDiagramURLs cp+ where+ c' = (map . left) getEString c+ left f (Left x) = Left (f x)+ left _ (Right x) = Right x++-- this is a bit of tomfoolery, if parseDiagramURLs does fail it+-- probably fails on something very particular and hard to stumble on+-- by chance.+prop_parseDiagramURLs_succeeds :: String -> Bool+prop_parseDiagramURLs_succeeds s+ = case P.parse parseDiagramURLs "" s of+ Left _ -> False+ Right _ -> True++instance Arbitrary CodeBlock where+ arbitrary = CodeBlock <$> arbitrary <*> arbSet <*> arbSet+ where arbSet = S.fromList <$> arbitrary++prop_tc_subset :: String -> [CodeBlock] -> Bool+prop_tc_subset s blocks = all (`elem` blocks) tc+ where tc = transitiveClosure s blocks++-- excluded blocks don't bind anything the included blocks need+prop_tc_excluded :: String -> [CodeBlock] -> Bool+prop_tc_excluded s blocks = S.null (excludedBindings `S.intersection` includedIdents)+ where included = transitiveClosure s blocks+ excluded = blocks \\ included+ excludedBindings = S.unions (map (view codeBlockBindings) excluded)+ includedIdents = S.unions (map (view codeBlockIdents) included)++-- included blocks do bind something which included blocks need+prop_tc_included :: String -> [CodeBlock] -> Bool+prop_tc_included s blocks =+ all ( not+ . S.null+ . (S.intersection includedIdents)+ . (view codeBlockBindings)+ )+ included+ where included = transitiveClosure s blocks+ includedIdents = S.insert s $ S.unions (map (view codeBlockIdents) included)++tests =+ [ testProperty "DiagramURL display/parse" prop_parseDisplay+ , testProperty "CommentWithURLs display/parse" prop_parseDisplayMany+ , testProperty "parseDiagramURLs succeeds" prop_parseDiagramURLs_succeeds++ , testProperty "transitiveClosure subset" prop_tc_subset+ , testProperty "transitiveClosure excluded bindings" prop_tc_excluded+ , testProperty "transitiveClosure included bindings" prop_tc_included+ ]++main = defaultMain tests
+ tools/diagrams-haddock.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TupleSections #-}+module Main where++import Control.Monad (forM_, when)+import Data.List (intercalate)+import Data.Version (showVersion)+import Diagrams.Haddock+import System.Console.CmdArgs+import System.Directory+import System.FilePath ((<.>), (</>))++import Distribution.ModuleName (toFilePath)+import qualified Distribution.PackageDescription as P+import Distribution.Simple.Configure (maybeGetPersistBuildConfig)+import Distribution.Simple.LocalBuildInfo (localPkgDescr)++import Language.Preprocessor.Cpphs++import Paths_diagrams_haddock (version)++data DiagramsHaddock+ = DiagramsHaddock+ { quiet :: Bool+ , cacheDir :: FilePath+ , outputDir :: FilePath+ , includeDirs :: [FilePath]+ , cppDefines :: [String]+ , targets :: [FilePath]+ }+ deriving (Show, Typeable, Data)++diagramsHaddockOpts :: DiagramsHaddock+diagramsHaddockOpts+ = DiagramsHaddock+ { quiet = False+ &= help "Suppress normal logging output"++ , cacheDir+ = ".diagrams-cache"+ &= typDir+ &= help "Directory for storing cached diagrams (default: .diagrams-cache)"++ , outputDir+ = "diagrams"+ &= typDir+ &= help "Directory to output compiled diagrams (default: diagrams)"++ , includeDirs+ = []+ &= typDir+ &= help "Include directory for CPP includes"++ , cppDefines+ = []+ &= typ "NAME"+ &= help "Preprocessor defines for CPP pass"++ , targets+ = def &= args &= typFile+ }+ &= program "diagrams-haddock"+ &= summary (unlines+ [ "diagrams-haddock v" ++ showVersion version ++ ", (c) 2013 diagrams-haddock team (see LICENSE)"+ , ""+ , "Compile inline diagrams code in Haddock documentation."+ , ""+ , "Pass diagrams-haddock the names of files to be processed, and/or"+ , "the names of directories containing Cabal packages. If no arguments"+ , "are given it assumes the current directory is a Cabal package."+ , ""+ , "For more detailed help, including details of how to create source files"+ , "for diagrams-haddock to process, consult the README at"+ , ""+ , " http://github.com/diagrams/diagrams-haddock/"+ ])++main :: IO ()+main = do+ opts <- cmdArgs diagramsHaddockOpts+ forM_ (targets opts) $ \targ -> do+ d <- doesDirectoryExist targ+ f <- doesFileExist targ+ case (d,f) of+ (True,_) -> processCabalPackage opts targ+ (_,True) -> processFile opts [] targ+ _ -> targetError targ+ when (null (targets opts)) $ processCabalPackage opts "."++targetError :: FilePath -> IO ()+targetError targ = putStrLn $ "Warning: target " ++ targ ++ " does not exist, ignoring."++-- | Process all the files in a Cabal package. At the moment, only+-- looks at files corresponding to exported modules from a library.+-- In other words, it does not consider the source for executables+-- or any unexported modules.+processCabalPackage :: DiagramsHaddock -> FilePath -> IO ()+processCabalPackage opts dir = do+ mlbi <- maybeGetPersistBuildConfig distDir+ case mlbi of+ Nothing -> putStrLn $+ "No setup-config found in " ++ distDir ++ ", please run 'cabal configure' first."+ Just lbi -> do+ let mlib = P.library . localPkgDescr $ lbi+ case mlib of+ Nothing -> return ()+ Just lib -> do+ let buildInfo = P.libBuildInfo lib+ srcDirs = P.hsSourceDirs buildInfo+ includes = P.includeDirs buildInfo+ defines = P.cppOptions buildInfo+ opts' = opts+ { includeDirs = includeDirs opts ++ includes+ }+ cabalDefines = parseCabalDefines defines+ mapM_ (tryProcessFile opts' cabalDefines dir srcDirs) . map toFilePath . P.exposedModules $ lib++ where distDir = dir </> "dist"++-- | Use @cpphs@'s options parser to handle the options from cabal.+parseCabalDefines :: [String] -> [(String,String)]+parseCabalDefines = either (const []) defines . parseOptions+++-- | Try to find and process a file corresponding to a module exported+-- from a library.+tryProcessFile+ :: DiagramsHaddock -- ^ options+ -> [(String,String)] -- ^ additional defines+ -> FilePath -- ^ base directory+ -> [FilePath] -- ^ haskell-src-dirs+ -> FilePath -- ^ name of the module to look for, in \"A/B/C\" form+ -> IO ()+tryProcessFile opts defines dir srcDirs fileBase = do+ let files = [ dir </> srcDir </> fileBase <.> ext+ | srcDir <- srcDirs+ , ext <- ["hs", "lhs"]+ ]+ forM_ files $ \f -> do+ e <- doesFileExist f+ when e $ processFile opts defines f++-- | Process a single file with diagrams-haddock.+processFile :: DiagramsHaddock -> [(String,String)] -> FilePath -> IO ()+processFile opts defines file = do+ errs <- processHaddockDiagrams' cpphsOpts (quiet opts) (cacheDir opts) (outputDir opts) file+ case errs of+ [] -> return ()+ _ -> putStrLn $ intercalate "\n" errs+ where+ cpphsOpts = defaultCpphsOptions+ { includes = includeDirs opts+ , defines = map (,"") (cppDefines opts) ++ defines+ , boolopts = defaultBoolOptions { hashline = False }+ }