{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# 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/src_Diagrams_Haddock_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.Arrow               (first, (&&&), (***))
import           Control.Lens                (makeLenses, orOf, view, (%%~),
                                              (%~), (&), (.~), (^.), _2, _Right)
import           Control.Monad               (when)
import           Control.Monad.Writer
import qualified Data.ByteString.Base64.Lazy as BS64
import qualified Data.ByteString.Lazy        as BS
import qualified Data.ByteString.Lazy.Char8  as BS8
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                   as T
import qualified Data.Text.Encoding          as T
import qualified Graphics.Svg                as G
import           Language.Haskell.Exts       hiding (loc)
import qualified Language.Haskell.Exts       as HSE
import           Language.Preprocessor.Cpphs
import           System.Console.ANSI         (setCursorColumn)
import           System.Directory            (copyFile,
                                              createDirectoryIfMissing,
                                              doesFileExist)
import           System.FilePath             (dropExtension, normalise,
                                              splitDirectories, (<.>), (</>))
import qualified System.IO                   as IO
import qualified System.IO.Strict            as Strict
import           Text.Parsec
import qualified Text.Parsec                 as P
import           Text.Parsec.String
import qualified UnliftIO.IO.File            as UIO

import           Diagrams.Backend.SVG        (Options (..), SVG (..))
import qualified Diagrams.Builder            as DB
import           Diagrams.Prelude            (V2, zero)
import           Diagrams.TwoD.Size          (mkSizeSpec2D)

------------------------------------------------------------
-- Utilities
------------------------------------------------------------

-- | Pretty-print a parse failure at a particular location.
showParseFailure :: SrcLoc -> String -> String
showParseFailure :: SrcLoc -> String -> String
showParseFailure SrcLoc
loc String
err = [String] -> String
unlines [ forall a. Pretty a => a -> String
prettyPrint SrcLoc
loc, String
err ]

-- | A simple monad for collecting a list of error messages.  There is
--   no facility for failing as such---in this model one simply
--   generates an error message and moves on.
newtype CollectErrors a = CE { forall a. CollectErrors a -> Writer [String] a
unCE :: Writer [String] a }
  deriving (forall a b. a -> CollectErrors b -> CollectErrors a
forall a b. (a -> b) -> CollectErrors a -> CollectErrors b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CollectErrors b -> CollectErrors a
$c<$ :: forall a b. a -> CollectErrors b -> CollectErrors a
fmap :: forall a b. (a -> b) -> CollectErrors a -> CollectErrors b
$cfmap :: forall a b. (a -> b) -> CollectErrors a -> CollectErrors b
Functor, Functor CollectErrors
forall a. a -> CollectErrors a
forall a b. CollectErrors a -> CollectErrors b -> CollectErrors a
forall a b. CollectErrors a -> CollectErrors b -> CollectErrors b
forall a b.
CollectErrors (a -> b) -> CollectErrors a -> CollectErrors b
forall a b c.
(a -> b -> c)
-> CollectErrors a -> CollectErrors b -> CollectErrors c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. CollectErrors a -> CollectErrors b -> CollectErrors a
$c<* :: forall a b. CollectErrors a -> CollectErrors b -> CollectErrors a
*> :: forall a b. CollectErrors a -> CollectErrors b -> CollectErrors b
$c*> :: forall a b. CollectErrors a -> CollectErrors b -> CollectErrors b
liftA2 :: forall a b c.
(a -> b -> c)
-> CollectErrors a -> CollectErrors b -> CollectErrors c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> CollectErrors a -> CollectErrors b -> CollectErrors c
<*> :: forall a b.
CollectErrors (a -> b) -> CollectErrors a -> CollectErrors b
$c<*> :: forall a b.
CollectErrors (a -> b) -> CollectErrors a -> CollectErrors b
pure :: forall a. a -> CollectErrors a
$cpure :: forall a. a -> CollectErrors a
Applicative, Applicative CollectErrors
forall a. a -> CollectErrors a
forall a b. CollectErrors a -> CollectErrors b -> CollectErrors b
forall a b.
CollectErrors a -> (a -> CollectErrors b) -> CollectErrors b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> CollectErrors a
$creturn :: forall a. a -> CollectErrors a
>> :: forall a b. CollectErrors a -> CollectErrors b -> CollectErrors b
$c>> :: forall a b. CollectErrors a -> CollectErrors b -> CollectErrors b
>>= :: forall a b.
CollectErrors a -> (a -> CollectErrors b) -> CollectErrors b
$c>>= :: forall a b.
CollectErrors a -> (a -> CollectErrors b) -> CollectErrors b
Monad, MonadWriter [String])

-- | Generate an error message and fail (by returning @Nothing@).
failWith :: String -> CollectErrors (Maybe a)
failWith :: forall a. String -> CollectErrors (Maybe a)
failWith String
err = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
err] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | Run a @CollectErrors@ computation, resulting in a value of type
--   @a@ along with the collection of generated error messages.
runCE :: CollectErrors a -> (a, [String])
runCE :: forall a. CollectErrors a -> (a, [String])
runCE = forall w a. Writer w a -> (a, w)
runWriter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. CollectErrors a -> Writer [String] a
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
_diagramURL  :: String
                  , DiagramURL -> String
_diagramName :: String
                  , DiagramURL -> Map String String
_diagramOpts :: M.Map String String
                  }
  deriving (Int -> DiagramURL -> String -> String
[DiagramURL] -> String -> String
DiagramURL -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DiagramURL] -> String -> String
$cshowList :: [DiagramURL] -> String -> String
show :: DiagramURL -> String
$cshow :: DiagramURL -> String
showsPrec :: Int -> DiagramURL -> String -> String
$cshowsPrec :: Int -> DiagramURL -> String -> String
Show, DiagramURL -> DiagramURL -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DiagramURL -> DiagramURL -> Bool
$c/= :: DiagramURL -> DiagramURL -> Bool
== :: DiagramURL -> DiagramURL -> Bool
$c== :: DiagramURL -> DiagramURL -> Bool
Eq)

makeLenses ''DiagramURL

-- | Display a diagram URL in the format @\<\<URL#diagram=name&key=val&...\>\>@.
displayDiagramURL :: DiagramURL -> String
displayDiagramURL :: DiagramURL -> String
displayDiagramURL DiagramURL
d = String
"<<" forall a. [a] -> [a] -> [a]
++ DiagramURL
d forall s a. s -> Getting a s a -> a
^. Lens' DiagramURL String
diagramURL forall a. [a] -> [a] -> [a]
++ String
"#" forall a. [a] -> [a] -> [a]
++ String
opts forall a. [a] -> [a] -> [a]
++ String
">>"
  where
    opts :: String
opts = forall a. [a] -> [[a]] -> [a]
intercalate String
"&"
         forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
displayOpt
         forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String
"diagram", DiagramURL
d forall s a. s -> Getting a s a -> a
^. Lens' DiagramURL String
diagramName) forall a. a -> [a] -> [a]
:)
         forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.assocs
         forall a b. (a -> b) -> a -> b
$ DiagramURL
d forall s a. s -> Getting a s a -> a
^. Lens' DiagramURL (Map String String)
diagramOpts
    displayOpt :: (String, String) -> String
displayOpt (String
k,String
v) = String
k forall a. [a] -> [a] -> [a]
++ String
"=" forall a. [a] -> [a] -> [a]
++ String
v

-- | Parse things of the form @\<\<URL#diagram=name&key=val&...\>\>@.
--   The URL is optional (the @#@, however, is required).
parseDiagramURL :: Parser DiagramURL
parseDiagramURL :: Parser DiagramURL
parseDiagramURL =
  String -> String -> Map String String -> DiagramURL
DiagramURL
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"<<" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"#>"))
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'#' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"diagram=" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"&>"))
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser (String, String)
parseKeyValPair) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
">>")

-- | Parse a key/value pair of the form @&key=val@.
parseKeyValPair :: Parser (String,String)
parseKeyValPair :: Parser (String, String)
parseKeyValPair =
  forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'&' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
  ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"&>=") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'=') forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"&>="))

-- | Parse a diagram URL /or/ a single character which is not the
--   start of a diagram URL.
maybeParseDiagramURL :: Parser (Either Char DiagramURL)
maybeParseDiagramURL :: Parser (Either Char DiagramURL)
maybeParseDiagramURL =
      forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser DiagramURL
parseDiagramURL
  forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall a b. a -> Either a b
Left  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar

-- | Decompose a string into a parsed form with explicitly represented
--   diagram URLs interspersed with other content.
parseDiagramURLs :: Parser [Either String DiagramURL]
parseDiagramURLs :: Parser [Either String DiagramURL]
parseDiagramURLs = forall a b. [Either a b] -> [Either [a] b]
condenseLefts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser (Either Char DiagramURL)
maybeParseDiagramURL
  where
    condenseLefts :: [Either a b] -> [Either [a] b]
    condenseLefts :: forall a b. [Either a b] -> [Either [a] b]
condenseLefts [] = []
    condenseLefts (Right b
a : [Either a b]
xs) = forall a b. b -> Either a b
Right b
a forall a. a -> [a] -> [a]
: forall a b. [Either a b] -> [Either [a] b]
condenseLefts [Either a b]
xs
    condenseLefts [Either a b]
xs = forall a b. a -> Either a b
Left (forall a b. [Either a b] -> [a]
lefts [Either a b]
ls) forall a. a -> [a] -> [a]
: forall a b. [Either a b] -> [Either [a] b]
condenseLefts [Either a b]
xs'
      where ([Either a b]
ls,[Either a b]
xs') = forall a. (a -> Bool) -> [a] -> ([a], [a])
span forall {a} {b}. Either a b -> Bool
isLeft [Either a b]
xs
            isLeft :: Either a b -> Bool
isLeft (Left {}) = Bool
True
            isLeft Either a b
_         = Bool
False

-- | Serialize a parsed comment with diagram URLs back into a String.
displayDiagramURLs :: [Either String DiagramURL] -> String
displayDiagramURLs :: [Either String DiagramURL] -> String
displayDiagramURLs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id DiagramURL -> String
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 -> Set String
getDiagramNames (Comment Bool
_ SrcSpan
_ String
s) =
  case forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
P.parse Parser [Either String DiagramURL]
parseDiagramURLs String
"" String
s of
    Left ParseError
_     -> forall a. HasCallStack => String -> a
error String
"This case can never happen; see prop_parseDiagramURLs_succeeds"
    Right [Either String DiagramURL]
urls -> forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' DiagramURL String
diagramName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> [b]
rights forall a b. (a -> b) -> a -> b
$ [Either String DiagramURL]
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 :: [Comment] -> [(String, Int)]
coalesceComments
  = forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Comment -> String
getComment forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Comment -> Int
commentLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head)

    -- discard no longer needed numbers
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst)

    -- group consecutive runs
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> b
snd))

    -- subtract consecutive numbers so runs show up as repeats
    -- e.g.  L1, L2, L3, L6, L7, L9  -->  0,0,0,2,2,3
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i Comment
c -> (Comment
c, Comment -> Int
commentLine Comment
c forall a. Num a => a -> a -> a
- Int
i)) [Int
1..])

    -- explode out each multi-line comment into its own singleton list,
    -- which will be unaffected by the above shenanigans
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\[Comment]
xs -> if Comment -> Bool
isMultiLine (forall a. [a] -> a
head [Comment]
xs) then forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> [a] -> [a]
:[]) [Comment]
xs else [[Comment]
xs])

    -- group multi + single line comments together
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Comment -> Bool
isMultiLine)

  where
    isMultiLine :: Comment -> Bool
isMultiLine (Comment Bool
b SrcSpan
_ String
_) = Bool
b
    getComment :: Comment -> String
getComment  (Comment Bool
_ SrcSpan
_ String
c) = String
c
    commentLine :: Comment -> Int
commentLine (Comment Bool
_ SrcSpan
s String
_) = SrcSpan -> Int
srcSpanStartLine SrcSpan
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
      { CodeBlock -> String
_codeBlockCode     :: String
      , CodeBlock -> Set String
_codeBlockIdents   :: S.Set String
      , CodeBlock -> Set String
_codeBlockBindings :: S.Set String
      }
  deriving (Int -> CodeBlock -> String -> String
[CodeBlock] -> String -> String
CodeBlock -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [CodeBlock] -> String -> String
$cshowList :: [CodeBlock] -> String -> String
show :: CodeBlock -> String
$cshow :: CodeBlock -> String
showsPrec :: Int -> CodeBlock -> String -> String
$cshowsPrec :: Int -> CodeBlock -> String -> String
Show, CodeBlock -> CodeBlock -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CodeBlock -> CodeBlock -> Bool
$c/= :: CodeBlock -> CodeBlock -> Bool
== :: CodeBlock -> CodeBlock -> Bool
$c== :: CodeBlock -> CodeBlock -> Bool
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 :: String -> (String, Int) -> CollectErrors (Maybe CodeBlock)
makeCodeBlock String
file (String
s,Int
l) =
  case ParseMode -> String -> ParseResult (Module SrcSpanInfo)
HSE.parseFileContentsWithMode ParseMode
parseMode String
s of
    ParseOk Module SrcSpanInfo
m           -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Set String -> Set String -> CodeBlock
CodeBlock String
s
                                             (Module SrcSpanInfo -> Set String
collectIdents Module SrcSpanInfo
m)
                                             (forall l. Module l -> Set String
collectBindings Module SrcSpanInfo
m)
    ParseFailed SrcLoc
loc String
err -> forall a. String -> CollectErrors (Maybe a)
failWith forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
      [ String
file forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
l forall a. [a] -> [a] -> [a]
++ String
":\nWarning: could not parse code block:" ]
      forall a. [a] -> [a] -> [a]
++
      String -> [String]
showBlock String
s
      forall a. [a] -> [a] -> [a]
++
      [ String
"Error was:" ]
      forall a. [a] -> [a] -> [a]
++
      (Int -> [String] -> [String]
indent Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall a b. (a -> b) -> a -> b
$ SrcLoc -> String -> String
showParseFailure SrcLoc
loc String
err)
  where
    parseMode :: ParseMode
parseMode = ParseMode
defaultParseMode
                { fixities :: Maybe [Fixity]
fixities     = forall a. Maybe a
Nothing
                , baseLanguage :: Language
baseLanguage = Language
Haskell2010
                , extensions :: [Extension]
extensions   = [KnownExtension -> Extension
EnableExtension KnownExtension
MultiParamTypeClasses]
                }
    indent :: Int -> [String] -> [String]
indent Int
n  = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> a -> [a]
replicate Int
n Char
' ' forall a. [a] -> [a] -> [a]
++)
    showBlock :: String -> [String]
showBlock String
b
      | forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls forall a. Ord a => a -> a -> Bool
> Int
5 = Int -> [String] -> [String]
indent Int
2 (forall a. Int -> [a] -> [a]
take Int
4 [String]
ls forall a. [a] -> [a] -> [a]
++ [String
"..."])
      | Bool
otherwise     = Int -> [String] -> [String]
indent Int
2 [String]
ls
      where ls :: [String]
ls = String -> [String]
lines String
b

-- | Collect the list of names bound in a module.
collectBindings :: Module l -> S.Set String
collectBindings :: forall l. Module l -> Set String
collectBindings (Module l
_ Maybe (ModuleHead l)
_ [ModulePragma l]
_ [ImportDecl l]
_ [Decl l]
decls) = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall l. Decl l -> Maybe String
getBinding [Decl l]
decls
collectBindings Module l
_ = forall a. Set a
S.empty

getBinding :: Decl l -> Maybe String
getBinding :: forall l. Decl l -> Maybe String
getBinding (FunBind l
_ [])                     = forall a. Maybe a
Nothing
getBinding (FunBind l
_ (Match l
_ Name l
nm [Pat l]
_ Rhs l
_ Maybe (Binds l)
_ : [Match l]
_)) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Name l -> String
getName Name l
nm
getBinding (PatBind l
_ (PVar l
_ Name l
nm) Rhs l
_ Maybe (Binds l)
_)        = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Name l -> String
getName Name l
nm
getBinding Decl l
_                                  = forall a. Maybe a
Nothing

getName :: Name l -> String
getName :: forall l. Name l -> String
getName (HSE.Ident l
_ String
s) = String
s
getName (Symbol l
_ String
s)    = String
s

getQName :: QName l -> Maybe String
getQName :: forall l. QName l -> Maybe String
getQName (Qual l
_ ModuleName l
_ Name l
n) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Name l -> String
getName Name l
n
getQName (UnQual l
_ Name l
n) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Name l -> String
getName Name l
n
getQName QName l
_            = forall a. Maybe a
Nothing

-- | Collect the list of referenced identifiers in a module.
collectIdents :: Module SrcSpanInfo -> S.Set String
collectIdents :: Module SrcSpanInfo -> Set String
collectIdents Module SrcSpanInfo
m = forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$
                    [ forall l. QName l -> Maybe String
getQName QName SrcSpanInfo
n
                    | (Var SrcSpanInfo
_ QName SrcSpanInfo
n :: Exp SrcSpanInfo) <- forall from to. Biplate from to => from -> [to]
universeBi Module SrcSpanInfo
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 :: String -> (String, Int) -> CollectErrors [CodeBlock]
extractCodeBlocks String
file (String
s,Int
l)
  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> (String, Int) -> CollectErrors (Maybe CodeBlock)
makeCodeBlock String
file forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> String
unlinesforall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
***forall a. [a] -> a
head) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> [a] -> [b]
mapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first) (forall a. Int -> [a] -> [a]
drop Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace))
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Splitter a -> [a] -> [[a]]
split forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Splitter a -> Splitter a
dropBlanks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Splitter a -> Splitter a
dropDelims forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Splitter a
whenElt (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isBird forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst))
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. [a] -> [b] -> [(a, b)]
zip [Int
l ..]
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
  forall a b. (a -> b) -> a -> b
$ String
s
  where
    isBird :: String -> Bool
isBird = (Bool -> Bool -> Bool
(||) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String
">"forall a. Eq a => a -> a -> Bool
==) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String
"> " forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
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 :: String -> String -> CollectErrors (Maybe ([CodeBlock], Set String))
parseCodeBlocks String
file String
src =
  case ParseMode -> String -> ParseResult (Module SrcSpanInfo, [Comment])
HSE.parseFileContentsWithComments ParseMode
parseMode String
src of
    ParseFailed SrcLoc
loc String
err -> forall a. String -> CollectErrors (Maybe a)
failWith forall a b. (a -> b) -> a -> b
$ SrcLoc -> String -> String
showParseFailure SrcLoc
loc String
err
    ParseOk (Module SrcSpanInfo
_, [Comment]
cs)     -> do
      [CodeBlock]
blocks <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> (String, Int) -> CollectErrors [CodeBlock]
extractCodeBlocks String
file)
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Comment] -> [(String, Int)]
coalesceComments
                forall a b. (a -> b) -> a -> b
$ [Comment]
cs
      let diaNames :: Set String
diaNames  = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Comment -> Set String
getDiagramNames forall a b. (a -> b) -> a -> b
$ [Comment]
cs

      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ([CodeBlock]
blocks, Set String
diaNames)
  where
    parseMode :: ParseMode
parseMode = ParseMode
defaultParseMode
                { fixities :: Maybe [Fixity]
fixities      = forall a. Maybe a
Nothing
                , parseFilename :: String
parseFilename = String
file
                , baseLanguage :: Language
baseLanguage  = Language
Haskell2010
                , extensions :: [Extension]
extensions    = [KnownExtension -> Extension
EnableExtension KnownExtension
MultiParamTypeClasses]
                }

-- | 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 :: String -> [CodeBlock] -> [CodeBlock]
transitiveClosure String
ident = [String] -> [CodeBlock] -> [CodeBlock]
tc [String
ident]
  where
    tc :: [String] -> [CodeBlock] -> [CodeBlock]
tc [String]
_ [] = []
    tc [] [CodeBlock]
_ = []
    tc (String
i:[String]
is) [CodeBlock]
blocks =
        let ([CodeBlock]
ins,[CodeBlock]
outs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\CodeBlock
cb -> String
i forall a. Ord a => a -> Set a -> Bool
`S.member` (CodeBlock
cb forall s a. s -> Getting a s a -> a
^. Lens' CodeBlock (Set String)
codeBlockBindings)) [CodeBlock]
blocks
        in  [CodeBlock]
ins forall a. [a] -> [a] -> [a]
++ [String] -> [CodeBlock] -> [CodeBlock]
tc ([String]
is forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. Set a -> [a]
S.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' CodeBlock (Set String)
codeBlockIdents) [CodeBlock]
ins) [CodeBlock]
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
               -> Bool       -- ^ @True@ = generate data URIs
               -> FilePath   -- ^ cache directory
               -> FilePath   -- ^ output directory
               -> FilePath   -- ^ file being processed
               -> S.Set String -- ^ diagrams referenced from URLs
               -> [CodeBlock]
               -> DiagramURL
               -> WriterT [String] IO (DiagramURL, Bool)
compileDiagram :: Bool
-> Bool
-> String
-> String
-> String
-> Set String
-> [CodeBlock]
-> DiagramURL
-> WriterT [String] IO (DiagramURL, Bool)
compileDiagram Bool
quiet Bool
dataURIs String
cacheDir String
outputDir String
file Set String
ds [CodeBlock]
code DiagramURL
url
    -- See https://github.com/diagrams/diagrams-haddock/issues/7 .
  | (DiagramURL
url forall s a. s -> Getting a s a -> a
^. Lens' DiagramURL String
diagramName) forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set String
ds = forall (m :: * -> *) a. Monad m => a -> m a
return (DiagramURL
url, Bool
False)

    -- The normal case.
  | Bool
otherwise = do
      let outFile :: String
outFile = String
outputDir String -> String -> String
</>
                    (String -> String
munge String
file forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ (DiagramURL
url forall s a. s -> Getting a s a -> a
^. Lens' DiagramURL String
diagramName)) String -> String -> String
<.> String
"svg"

          munge :: String -> String
munge   = forall a. [a] -> [[a]] -> [a]
intercalate String
"_" forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitDirectories forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
normalise forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dropExtension

          w, h :: Maybe Double
          w :: Maybe Double
w = forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
"width" (DiagramURL
url forall s a. s -> Getting a s a -> a
^. Lens' DiagramURL (Map String String)
diagramOpts)
          h :: Maybe Double
h = forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
"height" (DiagramURL
url forall s a. s -> Getting a s a -> a
^. Lens' DiagramURL (Map String String)
diagramOpts)

          oldURL :: (DiagramURL, Bool)
oldURL = (DiagramURL
url, Bool
False)
          newURL :: String -> (DiagramURL, Bool)
newURL String
content = (DiagramURL
url forall a b. a -> (a -> b) -> b
& Lens' DiagramURL String
diagramURL forall s t a b. ASetter s t a b -> b -> s -> t
.~ String
content, String
content forall a. Eq a => a -> a -> Bool
/= DiagramURL
urlforall s a. s -> Getting a s a -> a
^.Lens' DiagramURL String
diagramURL)

          neededCode :: [CodeBlock]
neededCode = String -> [CodeBlock] -> [CodeBlock]
transitiveClosure (DiagramURL
url forall s a. s -> Getting a s a -> a
^. Lens' DiagramURL String
diagramName) [CodeBlock]
code

          errHeader :: String
errHeader = String
file forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ (DiagramURL
url forall s a. s -> Getting a s a -> a
^. Lens' DiagramURL String
diagramName) forall a. [a] -> [a] -> [a]
++ String
":\n"

      BuildResult SVG V2 Double
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
cacheDir
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
dataURIs) forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
outputDir

        forall (m :: * -> *). MonadIO m => String -> m ()
logStr forall a b. (a -> b) -> a -> b
$ String
"[ ] " forall a. [a] -> [a] -> [a]
++ (DiagramURL
url forall s a. s -> Getting a s a -> a
^. Lens' DiagramURL String
diagramName)
        Handle -> IO ()
IO.hFlush Handle
IO.stdout

        let
                     bopts :: DB.BuildOpts SVG V2 Double
                     bopts :: BuildOpts SVG V2 Double
bopts = forall b (v :: * -> *) n.
b -> v n -> Options b v n -> BuildOpts b v n
DB.mkBuildOpts SVG
SVG forall (f :: * -> *) a. (Additive f, Num a) => f a
zero (forall n.
SizeSpec V2 n
-> Maybe Element -> Text -> [Attribute] -> Bool -> Options SVG V2 n
SVGOptions (forall n. Num n => Maybe n -> Maybe n -> SizeSpec V2 n
mkSizeSpec2D Maybe Double
w Maybe Double
h) forall a. Maybe a
Nothing Text
"" [] Bool
False)
                      forall a b. a -> (a -> b) -> b
& forall b (v :: * -> *) n. Lens' (BuildOpts b v n) [String]
DB.snippets forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a b. (a -> b) -> [a] -> [b]
map (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' CodeBlock String
codeBlockCode) [CodeBlock]
neededCode
                      forall a b. a -> (a -> b) -> b
& forall b (v :: * -> *) n. Lens' (BuildOpts b v n) [String]
DB.imports  forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ String
"Diagrams.Backend.SVG" ]
                      forall a b. a -> (a -> b) -> b
& forall b (v :: * -> *) n. Lens' (BuildOpts b v n) String
DB.diaExpr  forall s t a b. ASetter s t a b -> b -> s -> t
.~ (DiagramURL
url forall s a. s -> Getting a s a -> a
^. Lens' DiagramURL String
diagramName)
                      forall a b. a -> (a -> b) -> b
& forall b (v :: * -> *) n.
Lens'
  (BuildOpts b v n)
  (Int -> IO (Maybe (Options b v n -> Options b v n)))
DB.decideRegen forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall a.
(String -> a -> a) -> String -> Int -> IO (Maybe (a -> a))
DB.hashedRegenerate (\String
_ Options SVG V2 Double
opts -> Options SVG V2 Double
opts) String
cacheDir)
        forall b (v :: * -> *) n.
(Typeable b, Data (v n), Data n, Metric v, HasLinearMap v,
 Typeable v, OrderedField n, Backend b v n,
 Hashable (Options b v n)) =>
BuildOpts b v n -> IO (BuildResult b v n)
DB.buildDiagram BuildOpts SVG V2 Double
bopts

      case BuildResult SVG V2 Double
res of
        -- XXX incorporate these into error reporting framework instead of printing
        DB.ParseErr String
err    -> do
          forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
errHeader forall a. [a] -> [a] -> [a]
++ String
"Parse error: " forall a. [a] -> [a] -> [a]
++ String
err]
          forall (m :: * -> *). MonadIO m => String -> m ()
logResult String
"!"
          forall (m :: * -> *) a. Monad m => a -> m a
return (DiagramURL, Bool)
oldURL
        DB.InterpErr InterpreterError
ierr  -> do
          forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
errHeader forall a. [a] -> [a] -> [a]
++ String
"Interpreter error: " forall a. [a] -> [a] -> [a]
++ InterpreterError -> String
DB.ppInterpError InterpreterError
ierr]
          forall (m :: * -> *). MonadIO m => String -> m ()
logResult String
"!"
          forall (m :: * -> *) a. Monad m => a -> m a
return (DiagramURL, Bool)
oldURL
        DB.Skipped Int
hash    -> do
          let cached :: String
cached = String -> String
mkCached (Int -> String
DB.hashToHexStr Int
hash)
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
dataURIs) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
copyFile String
cached String
outFile
          forall (m :: * -> *). MonadIO m => String -> m ()
logResult String
"."
          if Bool
dataURIs
            then do
              ByteString
svgBS <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
cached
              forall (m :: * -> *) a. Monad m => a -> m a
return (String -> (DiagramURL, Bool)
newURL (ByteString -> String
mkDataURI ByteString
svgBS))
            else forall (m :: * -> *) a. Monad m => a -> m a
return (String -> (DiagramURL, Bool)
newURL String
outFile)
        DB.OK Int
hash Result SVG V2 Double
svg     -> do
          let cached :: String
cached = String -> String
mkCached (Int -> String
DB.hashToHexStr Int
hash)
              svgBS :: ByteString
svgBS  = Element -> ByteString
G.renderBS Result SVG V2 Double
svg
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BS.writeFile String
cached ByteString
svgBS
          (DiagramURL, Bool)
url' <- if Bool
dataURIs
                    then forall (m :: * -> *) a. Monad m => a -> m a
return (String -> (DiagramURL, Bool)
newURL (ByteString -> String
mkDataURI ByteString
svgBS))
                    else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> String -> IO ()
copyFile String
cached String
outFile forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (String -> (DiagramURL, Bool)
newURL String
outFile))
          forall (m :: * -> *). MonadIO m => String -> m ()
logResult String
"X"
          forall (m :: * -> *) a. Monad m => a -> m a
return (DiagramURL, Bool)
url'

 where
   mkCached :: String -> String
mkCached String
base = String
cacheDir String -> String -> String
</> String
base String -> String -> String
<.> String
"svg"
   mkDataURI :: ByteString -> String
mkDataURI ByteString
svg = String
"data:image/svg+xml;base64," forall a. [a] -> [a] -> [a]
++ ByteString -> String
BS8.unpack (ByteString -> ByteString
BS64.encode ByteString
svg)

   logStr, logResult :: MonadIO m => String -> m ()
   logStr :: forall (m :: * -> *). MonadIO m => String -> m ()
logStr      = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
quiet) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStr
   logResult :: forall (m :: * -> *). MonadIO m => String -> m ()
logResult String
s = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
quiet) forall a b. (a -> b) -> a -> b
$ do
     Int -> IO ()
setCursorColumn Int
1
     String -> IO ()
putStrLn String
s

-- | Compile all the diagrams referenced in an entire module.
compileDiagrams :: Bool          -- ^ @True@ = quiet
                -> Bool          -- ^ @True@ = generate data URIs
                -> FilePath      -- ^ cache directory
                -> FilePath      -- ^ output directory
                -> FilePath      -- ^ file being processed
                -> S.Set String  -- ^ diagram names referenced from URLs
                -> [CodeBlock]
                -> [Either String DiagramURL]
                -> WriterT [String] IO ([Either String DiagramURL], Bool)
compileDiagrams :: Bool
-> Bool
-> String
-> String
-> String
-> Set String
-> [CodeBlock]
-> [Either String DiagramURL]
-> WriterT [String] IO ([Either String DiagramURL], Bool)
compileDiagrams Bool
quiet Bool
dataURIs String
cacheDir String
outputDir String
file Set String
ds [CodeBlock]
cs [Either String DiagramURL]
urls = do
  [Either String (DiagramURL, Bool)]
urls' <- [Either String DiagramURL]
urls forall a b. a -> (a -> b) -> b
& (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a b. Prism (Either c a) (Either c b) a b
_Right)
                forall {k} (f :: k -> *) s (t :: k) a (b :: k).
LensLike f s t a b -> LensLike f s t a b
%%~ Bool
-> Bool
-> String
-> String
-> String
-> Set String
-> [CodeBlock]
-> DiagramURL
-> WriterT [String] IO (DiagramURL, Bool)
compileDiagram Bool
quiet Bool
dataURIs String
cacheDir String
outputDir String
file Set String
ds [CodeBlock]
cs
  let changed :: Bool
changed = forall s. Getting Any s Bool -> s -> Bool
orOf (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a b. Prism (Either c a) (Either c b) a b
_Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2) [Either String (DiagramURL, Bool)]
urls'
  forall (m :: * -> *) a. Monad m => a -> m a
return ([Either String (DiagramURL, Bool)]
urls' forall a b. a -> (a -> b) -> b
& (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a b. Prism (Either c a) (Either c b) a b
_Right) forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a b. (a, b) -> a
fst, Bool
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
  -> Bool       -- ^ generate data URIs?
  -> FilePath   -- ^ cache directory
  -> FilePath   -- ^ output directory
  -> FilePath   -- ^ file to be processed
  -> IO [String]
processHaddockDiagrams :: Bool -> Bool -> String -> String -> String -> IO [String]
processHaddockDiagrams = CpphsOptions
-> Bool -> Bool -> String -> String -> String -> IO [String]
processHaddockDiagrams' CpphsOptions
opts
  where
    opts :: CpphsOptions
opts = CpphsOptions
defaultCpphsOptions
         { boolopts :: BoolOptions
boolopts = BoolOptions
defaultBoolOptions { hashline :: Bool
hashline = Bool
False } }

-- | Version of 'processHaddockDiagrams' that takes options for @cpphs@.
processHaddockDiagrams'
  :: CpphsOptions -- ^ Options for cpphs
  -> Bool         -- ^ quiet
  -> Bool         -- ^ generate data URIs?
  -> FilePath     -- ^ cache directory
  -> FilePath     -- ^ output directory
  -> FilePath     -- ^ file to be processed
  -> IO [String]
processHaddockDiagrams' :: CpphsOptions
-> Bool -> Bool -> String -> String -> String -> IO [String]
processHaddockDiagrams' CpphsOptions
opts Bool
quiet Bool
dataURIs String
cacheDir String
outputDir String
file = do
  Bool
e   <- String -> IO Bool
doesFileExist String
file
  case Bool
e of
    Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return [String
"Error: " forall a. [a] -> [a] -> [a]
++ String
file forall a. [a] -> [a] -> [a]
++ String
" not found."]
    Bool
True  -> do
      -- always assume UTF-8, to make our lives simpler!
      Handle
h <- String -> IOMode -> IO Handle
IO.openFile String
file IOMode
IO.ReadMode
      Handle -> TextEncoding -> IO ()
IO.hSetEncoding Handle
h TextEncoding
IO.utf8
      String
src <- Handle -> IO String
Strict.hGetContents Handle
h
      (Maybe ([CodeBlock], Set String), [String])
r <- String -> IO (Maybe ([CodeBlock], Set String), [String])
go String
src
      case (Maybe ([CodeBlock], Set String), [String])
r of
        (Maybe ([CodeBlock], Set String)
Nothing,       [String]
msgs) -> forall (m :: * -> *) a. Monad m => a -> m a
return [String]
msgs
        (Just ([CodeBlock]
cs, Set String
ds), [String]
msgs) ->
          case forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
P.parse Parser [Either String DiagramURL]
parseDiagramURLs String
"" String
src of
            Left ParseError
_     ->
              forall a. HasCallStack => String -> a
error String
"This case can never happen; see prop_parseDiagramURLs_succeeds"
            Right [Either String DiagramURL]
urls -> do
              (([Either String DiagramURL]
urls', Bool
changed), [String]
msgs2) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$
                Bool
-> Bool
-> String
-> String
-> String
-> Set String
-> [CodeBlock]
-> [Either String DiagramURL]
-> WriterT [String] IO ([Either String DiagramURL], Bool)
compileDiagrams Bool
quiet Bool
dataURIs String
cacheDir String
outputDir String
file Set String
ds [CodeBlock]
cs [Either String DiagramURL]
urls
              let src' :: String
src' = [Either String DiagramURL] -> String
displayDiagramURLs [Either String DiagramURL]
urls'

              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
changed forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => String -> ByteString -> m ()
UIO.writeBinaryFileDurableAtomic String
file (Text -> ByteString
T.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
src')
              forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
msgs forall a. [a] -> [a] -> [a]
++ [String]
msgs2)
  where
    go :: String -> IO (Maybe ([CodeBlock], Set String), [String])
go String
src | String -> Bool
needsCPP String
src = String -> IO String
runCpp String
src forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. CollectErrors a -> (a, [String])
runCE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> CollectErrors (Maybe ([CodeBlock], Set String))
parseCodeBlocks String
file
           | Bool
otherwise    = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. CollectErrors a -> (a, [String])
runCE (String -> String -> CollectErrors (Maybe ([CodeBlock], Set String))
parseCodeBlocks String
file String
src)

    needsCPP :: String -> Bool
needsCPP String
src = case String -> Maybe (Maybe Language, [Extension])
readExtensions String
src of
                     Just (Maybe Language
_, [Extension]
es) | KnownExtension -> Extension
EnableExtension KnownExtension
CPP forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Extension]
es -> Bool
True
                     Maybe (Maybe Language, [Extension])
_                                            -> Bool
False

    runCpp :: String -> IO String
runCpp String
s = CpphsOptions -> String -> String -> IO String
runCpphs CpphsOptions
opts String
file String
s