{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Diagrams.Haddock
(
DiagramURL(..)
, displayDiagramURL
, parseDiagramURL
, parseKeyValPair
, maybeParseDiagramURL
, parseDiagramURLs
, displayDiagramURLs
, getDiagramNames
, coalesceComments
, CodeBlock(..)
, codeBlockCode, codeBlockIdents, codeBlockBindings
, makeCodeBlock
, collectBindings
, extractCodeBlocks
, parseCodeBlocks
, transitiveClosure
, compileDiagram
, compileDiagrams
, processHaddockDiagrams
, processHaddockDiagrams'
, 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)
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 ]
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])
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
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
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
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
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
">>")
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
"&>="))
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
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
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)
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
coalesceComments :: [Comment] -> [(String, Int)]
= 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)
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)
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))
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..])
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])
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
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
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
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
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
]
extractCodeBlocks :: FilePath -> (String,Int) -> CollectErrors [CodeBlock]
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
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]
}
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
compileDiagram :: Bool
-> Bool
-> FilePath
-> FilePath
-> FilePath
-> S.Set String
-> [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
| (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)
| 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
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
compileDiagrams :: Bool
-> Bool
-> FilePath
-> FilePath
-> FilePath
-> S.Set String
-> [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)
processHaddockDiagrams
:: Bool
-> Bool
-> FilePath
-> FilePath
-> FilePath
-> 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 } }
processHaddockDiagrams'
:: CpphsOptions
-> Bool
-> Bool
-> FilePath
-> FilePath
-> FilePath
-> 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
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