diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,4 @@ +0.1.0.0 (23 March 2013) +----------------------- + +Initial release! diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 +`<>`. To indicate an image which should be automatically +generated from some diagrams code, use the special syntax +`<>`. 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 + + <> + +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: +-- +-- <> +-- +-- > 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: +-- +-- <> +-- +-- > blueC = circle 1 # makeitblue +-- +-- And here is a blue square: +-- +-- <> +-- +-- > 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). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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 + } diff --git a/diagrams-haddock.cabal b/diagrams-haddock.cabal new file mode 100644 --- /dev/null +++ b/diagrams-haddock.cabal @@ -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 + . + . + For a good example of a package making use of + diagrams-haddock, see the diagrams-contrib + package + (). +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 diff --git a/diagrams/greenCircle.svg b/diagrams/greenCircle.svg new file mode 100644 --- /dev/null +++ b/diagrams/greenCircle.svg @@ -0,0 +1,4 @@ + + + diff --git a/src/Diagrams/Haddock.hs b/src/Diagrams/Haddock.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Haddock.hs @@ -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: +-- +-- <> +-- +-- 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: . +-- +-- For complete documentation and examples, see +-- . +----------------------------------------------------------------------------- +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 +-- @\<\\>@. To indicate an image which should be automatically +-- generated from some diagrams code, we use the special syntax +-- @\<\\>@. 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 @\<\\>@. +data DiagramURL = DiagramURL + { _diagramURL :: String + , _diagramName :: String + , _diagramOpts :: M.Map String String + } + deriving (Show, Eq) + +makeLenses ''DiagramURL + +-- | Display a diagram URL in the format @\<\\>@. +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 @\<\\>@. +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: +-- .) +-- 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 diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -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 diff --git a/tools/diagrams-haddock.hs b/tools/diagrams-haddock.hs new file mode 100644 --- /dev/null +++ b/tools/diagrams-haddock.hs @@ -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 } + }