{-# 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.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 [ SrcLoc -> String
forall a. Pretty a => a -> String
prettyPrint SrcLoc
loc, String
err ]
newtype CollectErrors a = CE { CollectErrors a -> Writer [String] a
unCE :: Writer [String] a }
deriving (a -> CollectErrors b -> CollectErrors a
(a -> b) -> CollectErrors a -> CollectErrors b
(forall a b. (a -> b) -> CollectErrors a -> CollectErrors b)
-> (forall a b. a -> CollectErrors b -> CollectErrors a)
-> Functor CollectErrors
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
<$ :: a -> CollectErrors b -> CollectErrors a
$c<$ :: forall a b. a -> CollectErrors b -> CollectErrors a
fmap :: (a -> b) -> CollectErrors a -> CollectErrors b
$cfmap :: forall a b. (a -> b) -> CollectErrors a -> CollectErrors b
Functor, Functor CollectErrors
a -> CollectErrors a
Functor CollectErrors
-> (forall a. a -> CollectErrors a)
-> (forall a b.
CollectErrors (a -> b) -> CollectErrors a -> CollectErrors b)
-> (forall a b c.
(a -> b -> c)
-> CollectErrors a -> CollectErrors b -> CollectErrors c)
-> (forall a b.
CollectErrors a -> CollectErrors b -> CollectErrors b)
-> (forall a b.
CollectErrors a -> CollectErrors b -> CollectErrors a)
-> Applicative CollectErrors
CollectErrors a -> CollectErrors b -> CollectErrors b
CollectErrors a -> CollectErrors b -> CollectErrors a
CollectErrors (a -> b) -> CollectErrors a -> CollectErrors b
(a -> b -> c)
-> CollectErrors a -> CollectErrors b -> CollectErrors c
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
<* :: CollectErrors a -> CollectErrors b -> CollectErrors a
$c<* :: forall a b. CollectErrors a -> CollectErrors b -> CollectErrors a
*> :: CollectErrors a -> CollectErrors b -> CollectErrors b
$c*> :: forall a b. CollectErrors a -> CollectErrors b -> CollectErrors b
liftA2 :: (a -> b -> c)
-> CollectErrors a -> CollectErrors b -> CollectErrors c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> CollectErrors a -> CollectErrors b -> CollectErrors c
<*> :: CollectErrors (a -> b) -> CollectErrors a -> CollectErrors b
$c<*> :: forall a b.
CollectErrors (a -> b) -> CollectErrors a -> CollectErrors b
pure :: a -> CollectErrors a
$cpure :: forall a. a -> CollectErrors a
$cp1Applicative :: Functor CollectErrors
Applicative, Applicative CollectErrors
a -> CollectErrors a
Applicative CollectErrors
-> (forall a b.
CollectErrors a -> (a -> CollectErrors b) -> CollectErrors b)
-> (forall a b.
CollectErrors a -> CollectErrors b -> CollectErrors b)
-> (forall a. a -> CollectErrors a)
-> Monad CollectErrors
CollectErrors a -> (a -> CollectErrors b) -> CollectErrors b
CollectErrors a -> CollectErrors b -> CollectErrors b
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 :: a -> CollectErrors a
$creturn :: forall a. a -> CollectErrors a
>> :: CollectErrors a -> CollectErrors b -> CollectErrors b
$c>> :: forall a b. CollectErrors a -> CollectErrors b -> CollectErrors b
>>= :: CollectErrors a -> (a -> CollectErrors b) -> CollectErrors b
$c>>= :: forall a b.
CollectErrors a -> (a -> CollectErrors b) -> CollectErrors b
$cp1Monad :: Applicative CollectErrors
Monad, MonadWriter [String])
failWith :: String -> CollectErrors (Maybe a)
failWith :: String -> CollectErrors (Maybe a)
failWith String
err = [String] -> CollectErrors ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
err] CollectErrors ()
-> CollectErrors (Maybe a) -> CollectErrors (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> CollectErrors (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
runCE :: CollectErrors a -> (a, [String])
runCE :: CollectErrors a -> (a, [String])
runCE = Writer [String] a -> (a, [String])
forall w a. Writer w a -> (a, w)
runWriter (Writer [String] a -> (a, [String]))
-> (CollectErrors a -> Writer [String] a)
-> CollectErrors a
-> (a, [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CollectErrors a -> Writer [String] a
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
(Int -> DiagramURL -> String -> String)
-> (DiagramURL -> String)
-> ([DiagramURL] -> String -> String)
-> Show DiagramURL
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
(DiagramURL -> DiagramURL -> Bool)
-> (DiagramURL -> DiagramURL -> Bool) -> Eq DiagramURL
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
"<<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ DiagramURL
d DiagramURL -> Getting String DiagramURL String -> String
forall s a. s -> Getting a s a -> a
^. Getting String DiagramURL String
Lens' DiagramURL String
diagramURL String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opts String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">>"
where
opts :: String
opts = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"&"
([String] -> String)
-> (Map String String -> [String]) -> Map String String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
displayOpt
([(String, String)] -> [String])
-> (Map String String -> [(String, String)])
-> Map String String
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String
"diagram", DiagramURL
d DiagramURL -> Getting String DiagramURL String -> String
forall s a. s -> Getting a s a -> a
^. Getting String DiagramURL String
Lens' DiagramURL String
diagramName) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:)
([(String, String)] -> [(String, String)])
-> (Map String String -> [(String, String)])
-> Map String String
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
M.assocs
(Map String String -> String) -> Map String String -> String
forall a b. (a -> b) -> a -> b
$ DiagramURL
d DiagramURL
-> Getting (Map String String) DiagramURL (Map String String)
-> Map String String
forall s a. s -> Getting a s a -> a
^. Getting (Map String String) DiagramURL (Map String String)
Lens' DiagramURL (Map String String)
diagramOpts
displayOpt :: (String, String) -> String
displayOpt (String
k,String
v) = String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v
parseDiagramURL :: Parser DiagramURL
parseDiagramURL :: Parser DiagramURL
parseDiagramURL =
String -> String -> Map String String -> DiagramURL
DiagramURL
(String -> String -> Map String String -> DiagramURL)
-> ParsecT String () Identity String
-> ParsecT
String () Identity (String -> Map String String -> DiagramURL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"<<" ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"#>"))
ParsecT
String () Identity (String -> Map String String -> DiagramURL)
-> ParsecT String () Identity String
-> ParsecT String () Identity (Map String String -> DiagramURL)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'#' ParsecT String () Identity Char
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"diagram=" ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"&>"))
ParsecT String () Identity (Map String String -> DiagramURL)
-> ParsecT String () Identity (Map String String)
-> Parser DiagramURL
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (([(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, String)] -> Map String String)
-> ParsecT String () Identity [(String, String)]
-> ParsecT String () Identity (Map String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity (String, String)
-> ParsecT String () Identity [(String, String)]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity (String, String)
parseKeyValPair) ParsecT String () Identity (Map String String)
-> ParsecT String () Identity String
-> ParsecT String () Identity (Map String String)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
">>")
parseKeyValPair :: Parser (String,String)
parseKeyValPair :: ParsecT String () Identity (String, String)
parseKeyValPair =
Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'&' ParsecT String () Identity Char
-> ParsecT String () Identity (String, String)
-> ParsecT String () Identity (String, String)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
((,) (String -> String -> (String, String))
-> ParsecT String () Identity String
-> ParsecT String () Identity (String -> (String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"&>=") ParsecT String () Identity String
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'=') ParsecT String () Identity (String -> (String, String))
-> ParsecT String () Identity String
-> ParsecT String () Identity (String, String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String () Identity Char
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 =
DiagramURL -> Either Char DiagramURL
forall a b. b -> Either a b
Right (DiagramURL -> Either Char DiagramURL)
-> Parser DiagramURL -> Parser (Either Char DiagramURL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser DiagramURL -> Parser DiagramURL
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser DiagramURL
parseDiagramURL
Parser (Either Char DiagramURL)
-> Parser (Either Char DiagramURL)
-> Parser (Either Char DiagramURL)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> Either Char DiagramURL
forall a b. a -> Either a b
Left (Char -> Either Char DiagramURL)
-> ParsecT String () Identity Char
-> Parser (Either Char DiagramURL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Char
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 = [Either Char DiagramURL] -> [Either String DiagramURL]
forall a b. [Either a b] -> [Either [a] b]
condenseLefts ([Either Char DiagramURL] -> [Either String DiagramURL])
-> ParsecT String () Identity [Either Char DiagramURL]
-> Parser [Either String DiagramURL]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Either Char DiagramURL)
-> ParsecT String () Identity [Either Char DiagramURL]
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 :: [Either a b] -> [Either [a] b]
condenseLefts [] = []
condenseLefts (Right b
a : [Either a b]
xs) = b -> Either [a] b
forall a b. b -> Either a b
Right b
a Either [a] b -> [Either [a] b] -> [Either [a] b]
forall a. a -> [a] -> [a]
: [Either a b] -> [Either [a] b]
forall a b. [Either a b] -> [Either [a] b]
condenseLefts [Either a b]
xs
condenseLefts [Either a b]
xs = [a] -> Either [a] b
forall a b. a -> Either a b
Left ([Either a b] -> [a]
forall a b. [Either a b] -> [a]
lefts [Either a b]
ls) Either [a] b -> [Either [a] b] -> [Either [a] b]
forall a. a -> [a] -> [a]
: [Either a b] -> [Either [a] b]
forall a b. [Either a b] -> [Either [a] b]
condenseLefts [Either a b]
xs'
where ([Either a b]
ls,[Either a b]
xs') = (Either a b -> Bool)
-> [Either a b] -> ([Either a b], [Either a b])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Either a b -> Bool
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 = (Either String DiagramURL -> String)
-> [Either String DiagramURL] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> String)
-> (DiagramURL -> String) -> Either String DiagramURL -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> String
forall a. a -> a
id DiagramURL -> String
displayDiagramURL)
getDiagramNames :: Comment -> S.Set String
getDiagramNames :: Comment -> Set String
getDiagramNames (Comment Bool
_ SrcSpan
_ String
s) =
case Parser [Either String DiagramURL]
-> String -> String -> Either ParseError [Either String DiagramURL]
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
_ -> String -> Set String
forall a. HasCallStack => String -> a
error String
"This case can never happen; see prop_parseDiagramURLs_succeeds"
Right [Either String DiagramURL]
urls -> [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String)
-> ([Either String DiagramURL] -> [String])
-> [Either String DiagramURL]
-> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DiagramURL -> String) -> [DiagramURL] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Getting String DiagramURL String -> DiagramURL -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String DiagramURL String
Lens' DiagramURL String
diagramName) ([DiagramURL] -> [String])
-> ([Either String DiagramURL] -> [DiagramURL])
-> [Either String DiagramURL]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either String DiagramURL] -> [DiagramURL]
forall a b. [Either a b] -> [b]
rights ([Either String DiagramURL] -> Set String)
-> [Either String DiagramURL] -> Set String
forall a b. (a -> b) -> a -> b
$ [Either String DiagramURL]
urls
coalesceComments :: [Comment] -> [(String, Int)]
= ([Comment] -> (String, Int)) -> [[Comment]] -> [(String, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String
unlines ([String] -> String)
-> ([Comment] -> [String]) -> [Comment] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Comment -> String) -> [Comment] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Comment -> String
getComment ([Comment] -> String)
-> ([Comment] -> Int) -> [Comment] -> (String, Int)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Comment -> Int
commentLine (Comment -> Int) -> ([Comment] -> Comment) -> [Comment] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Comment] -> Comment
forall a. [a] -> a
head)
([[Comment]] -> [(String, Int)])
-> ([Comment] -> [[Comment]]) -> [Comment] -> [(String, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Comment, Int)] -> [Comment])
-> [[(Comment, Int)]] -> [[Comment]]
forall a b. (a -> b) -> [a] -> [b]
map (((Comment, Int) -> Comment) -> [(Comment, Int)] -> [Comment]
forall a b. (a -> b) -> [a] -> [b]
map (Comment, Int) -> Comment
forall a b. (a, b) -> a
fst)
([[(Comment, Int)]] -> [[Comment]])
-> ([Comment] -> [[(Comment, Int)]]) -> [Comment] -> [[Comment]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Comment, Int)] -> [[(Comment, Int)]])
-> [[(Comment, Int)]] -> [[(Comment, Int)]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Comment, Int) -> (Comment, Int) -> Bool)
-> [(Comment, Int)] -> [[(Comment, Int)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Int -> Int -> Bool)
-> ((Comment, Int) -> Int)
-> (Comment, Int)
-> (Comment, Int)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Comment, Int) -> Int
forall a b. (a, b) -> b
snd))
([[(Comment, Int)]] -> [[(Comment, Int)]])
-> ([Comment] -> [[(Comment, Int)]])
-> [Comment]
-> [[(Comment, Int)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Comment] -> [(Comment, Int)])
-> [[Comment]] -> [[(Comment, Int)]]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Comment -> (Comment, Int))
-> [Int] -> [Comment] -> [(Comment, Int)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i Comment
c -> (Comment
c, Comment -> Int
commentLine Comment
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)) [Int
1..])
([[Comment]] -> [[(Comment, Int)]])
-> ([Comment] -> [[Comment]]) -> [Comment] -> [[(Comment, Int)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Comment] -> [[Comment]]) -> [[Comment]] -> [[Comment]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\[Comment]
xs -> if Comment -> Bool
isMultiLine ([Comment] -> Comment
forall a. [a] -> a
head [Comment]
xs) then (Comment -> [Comment]) -> [Comment] -> [[Comment]]
forall a b. (a -> b) -> [a] -> [b]
map (Comment -> [Comment] -> [Comment]
forall a. a -> [a] -> [a]
:[]) [Comment]
xs else [[Comment]
xs])
([[Comment]] -> [[Comment]])
-> ([Comment] -> [[Comment]]) -> [Comment] -> [[Comment]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Comment -> Comment -> Bool) -> [Comment] -> [[Comment]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Bool -> Bool -> Bool)
-> (Comment -> Bool) -> Comment -> Comment -> 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
(Int -> CodeBlock -> String -> String)
-> (CodeBlock -> String)
-> ([CodeBlock] -> String -> String)
-> Show CodeBlock
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
(CodeBlock -> CodeBlock -> Bool)
-> (CodeBlock -> CodeBlock -> Bool) -> Eq CodeBlock
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 -> Maybe CodeBlock -> CollectErrors (Maybe CodeBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CodeBlock -> CollectErrors (Maybe CodeBlock))
-> (CodeBlock -> Maybe CodeBlock)
-> CodeBlock
-> CollectErrors (Maybe CodeBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeBlock -> Maybe CodeBlock
forall a. a -> Maybe a
Just (CodeBlock -> CollectErrors (Maybe CodeBlock))
-> CodeBlock -> CollectErrors (Maybe CodeBlock)
forall a b. (a -> b) -> a -> b
$ String -> Set String -> Set String -> CodeBlock
CodeBlock String
s
(Module SrcSpanInfo -> Set String
collectIdents Module SrcSpanInfo
m)
(Module SrcSpanInfo -> Set String
forall l. Module l -> Set String
collectBindings Module SrcSpanInfo
m)
ParseFailed SrcLoc
loc String
err -> String -> CollectErrors (Maybe CodeBlock)
forall a. String -> CollectErrors (Maybe a)
failWith (String -> CollectErrors (Maybe CodeBlock))
-> ([String] -> String)
-> [String]
-> CollectErrors (Maybe CodeBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> CollectErrors (Maybe CodeBlock))
-> [String] -> CollectErrors (Maybe CodeBlock)
forall a b. (a -> b) -> a -> b
$
[ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\nWarning: could not parse code block:" ]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
String -> [String]
showBlock String
s
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
[ String
"Error was:" ]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
(Int -> [String] -> [String]
indent Int
2 ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String]) -> String -> [String]
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 = Maybe [Fixity]
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 = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++)
showBlock :: String -> [String]
showBlock String
b
| [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
5 = Int -> [String] -> [String]
indent Int
2 (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
4 [String]
ls [String] -> [String] -> [String]
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 :: Module l -> Set String
collectBindings (Module l
_ Maybe (ModuleHead l)
_ [ModulePragma l]
_ [ImportDecl l]
_ [Decl l]
decls) = [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String) -> [String] -> Set String
forall a b. (a -> b) -> a -> b
$ (Decl l -> Maybe String) -> [Decl l] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Decl l -> Maybe String
forall l. Decl l -> Maybe String
getBinding [Decl l]
decls
collectBindings Module l
_ = Set String
forall a. Set a
S.empty
getBinding :: Decl l -> Maybe String
getBinding :: Decl l -> Maybe String
getBinding (FunBind l
_ []) = Maybe String
forall a. Maybe a
Nothing
getBinding (FunBind l
_ (Match l
_ Name l
nm [Pat l]
_ Rhs l
_ Maybe (Binds l)
_ : [Match l]
_)) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Name l -> String
forall l. Name l -> String
getName Name l
nm
getBinding (PatBind l
_ (PVar l
_ Name l
nm) Rhs l
_ Maybe (Binds l)
_) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Name l -> String
forall l. Name l -> String
getName Name l
nm
getBinding Decl l
_ = Maybe String
forall a. Maybe a
Nothing
getName :: Name l -> String
getName :: Name l -> String
getName (HSE.Ident l
_ String
s) = String
s
getName (Symbol l
_ String
s) = String
s
getQName :: QName l -> Maybe String
getQName :: QName l -> Maybe String
getQName (Qual l
_ ModuleName l
_ Name l
n) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Name l -> String
forall l. Name l -> String
getName Name l
n
getQName (UnQual l
_ Name l
n) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Name l -> String
forall l. Name l -> String
getName Name l
n
getQName QName l
_ = Maybe String
forall a. Maybe a
Nothing
collectIdents :: Module SrcSpanInfo -> S.Set String
collectIdents :: Module SrcSpanInfo -> Set String
collectIdents Module SrcSpanInfo
m = [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String)
-> ([Maybe String] -> [String]) -> [Maybe String] -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> Set String) -> [Maybe String] -> Set String
forall a b. (a -> b) -> a -> b
$
[ QName SrcSpanInfo -> Maybe String
forall l. QName l -> Maybe String
getQName QName SrcSpanInfo
n
| (Var SrcSpanInfo
_ QName SrcSpanInfo
n :: Exp SrcSpanInfo) <- Module SrcSpanInfo -> [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)
= ([Maybe CodeBlock] -> [CodeBlock])
-> CollectErrors [Maybe CodeBlock] -> CollectErrors [CodeBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe CodeBlock] -> [CodeBlock]
forall a. [Maybe a] -> [a]
catMaybes
(CollectErrors [Maybe CodeBlock] -> CollectErrors [CodeBlock])
-> (String -> CollectErrors [Maybe CodeBlock])
-> String
-> CollectErrors [CodeBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(String, Int)] -> CollectErrors (Maybe CodeBlock))
-> [[(String, Int)]] -> CollectErrors [Maybe CodeBlock]
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 ((String, Int) -> CollectErrors (Maybe CodeBlock))
-> ([(String, Int)] -> (String, Int))
-> [(String, Int)]
-> CollectErrors (Maybe CodeBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> String
unlines([String] -> String)
-> ([Int] -> Int) -> ([String], [Int]) -> (String, Int)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
***[Int] -> Int
forall a. [a] -> a
head) (([String], [Int]) -> (String, Int))
-> ([(String, Int)] -> ([String], [Int]))
-> [(String, Int)]
-> (String, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, Int)] -> ([String], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(String, Int)] -> ([String], [Int]))
-> ([(String, Int)] -> [(String, Int)])
-> [(String, Int)]
-> ([String], [Int])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((String, Int) -> (String, Int))
-> [(String, Int)] -> [(String, Int)]
forall a b. (a -> b) -> [a] -> [b]
map(((String, Int) -> (String, Int))
-> [(String, Int)] -> [(String, Int)])
-> ((String -> String) -> (String, Int) -> (String, Int))
-> (String -> String)
-> [(String, Int)]
-> [(String, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(String -> String) -> (String, Int) -> (String, Int)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first) (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace))
([[(String, Int)]] -> CollectErrors [Maybe CodeBlock])
-> (String -> [[(String, Int)]])
-> String
-> CollectErrors [Maybe CodeBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Splitter (String, Int) -> [(String, Int)] -> [[(String, Int)]]
forall a. Splitter a -> [a] -> [[a]]
split (Splitter (String, Int) -> [(String, Int)] -> [[(String, Int)]])
-> (Splitter (String, Int) -> Splitter (String, Int))
-> Splitter (String, Int)
-> [(String, Int)]
-> [[(String, Int)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Splitter (String, Int) -> Splitter (String, Int)
forall a. Splitter a -> Splitter a
dropBlanks (Splitter (String, Int) -> Splitter (String, Int))
-> (Splitter (String, Int) -> Splitter (String, Int))
-> Splitter (String, Int)
-> Splitter (String, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Splitter (String, Int) -> Splitter (String, Int)
forall a. Splitter a -> Splitter a
dropDelims (Splitter (String, Int) -> [(String, Int)] -> [[(String, Int)]])
-> Splitter (String, Int) -> [(String, Int)] -> [[(String, Int)]]
forall a b. (a -> b) -> a -> b
$ ((String, Int) -> Bool) -> Splitter (String, Int)
forall a. (a -> Bool) -> Splitter a
whenElt (Bool -> Bool
not (Bool -> Bool) -> ((String, Int) -> Bool) -> (String, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isBird (String -> Bool)
-> ((String, Int) -> String) -> (String, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Int) -> String
forall a b. (a, b) -> a
fst))
([(String, Int)] -> [[(String, Int)]])
-> (String -> [(String, Int)]) -> String -> [[(String, Int)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> [Int] -> [(String, Int)])
-> [Int] -> [String] -> [(String, Int)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [String] -> [Int] -> [(String, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
l ..]
([String] -> [(String, Int)])
-> (String -> [String]) -> String -> [(String, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
(String -> CollectErrors [CodeBlock])
-> String -> CollectErrors [CodeBlock]
forall a b. (a -> b) -> a -> b
$ String
s
where
isBird :: String -> Bool
isBird = (Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool)
-> (String -> Bool) -> String -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String
">"String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String
"> " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)) (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
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 -> String -> CollectErrors (Maybe ([CodeBlock], Set String))
forall a. String -> CollectErrors (Maybe a)
failWith (String -> CollectErrors (Maybe ([CodeBlock], Set String)))
-> String -> CollectErrors (Maybe ([CodeBlock], Set String))
forall a b. (a -> b) -> a -> b
$ SrcLoc -> String -> String
showParseFailure SrcLoc
loc String
err
ParseOk (Module SrcSpanInfo
_, [Comment]
cs) -> do
[CodeBlock]
blocks <- ([[CodeBlock]] -> [CodeBlock])
-> CollectErrors [[CodeBlock]] -> CollectErrors [CodeBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[CodeBlock]] -> [CodeBlock]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
(CollectErrors [[CodeBlock]] -> CollectErrors [CodeBlock])
-> ([Comment] -> CollectErrors [[CodeBlock]])
-> [Comment]
-> CollectErrors [CodeBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Int) -> CollectErrors [CodeBlock])
-> [(String, Int)] -> CollectErrors [[CodeBlock]]
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)
([(String, Int)] -> CollectErrors [[CodeBlock]])
-> ([Comment] -> [(String, Int)])
-> [Comment]
-> CollectErrors [[CodeBlock]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Comment] -> [(String, Int)]
coalesceComments
([Comment] -> CollectErrors [CodeBlock])
-> [Comment] -> CollectErrors [CodeBlock]
forall a b. (a -> b) -> a -> b
$ [Comment]
cs
let diaNames :: Set String
diaNames = [Set String] -> Set String
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set String] -> Set String)
-> ([Comment] -> [Set String]) -> [Comment] -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Comment -> Set String) -> [Comment] -> [Set String]
forall a b. (a -> b) -> [a] -> [b]
map Comment -> Set String
getDiagramNames ([Comment] -> Set String) -> [Comment] -> Set String
forall a b. (a -> b) -> a -> b
$ [Comment]
cs
Maybe ([CodeBlock], Set String)
-> CollectErrors (Maybe ([CodeBlock], Set String))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([CodeBlock], Set String)
-> CollectErrors (Maybe ([CodeBlock], Set String)))
-> (([CodeBlock], Set String) -> Maybe ([CodeBlock], Set String))
-> ([CodeBlock], Set String)
-> CollectErrors (Maybe ([CodeBlock], Set String))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CodeBlock], Set String) -> Maybe ([CodeBlock], Set String)
forall a. a -> Maybe a
Just (([CodeBlock], Set String)
-> CollectErrors (Maybe ([CodeBlock], Set String)))
-> ([CodeBlock], Set String)
-> CollectErrors (Maybe ([CodeBlock], Set String))
forall a b. (a -> b) -> a -> b
$ ([CodeBlock]
blocks, Set String
diaNames)
where
parseMode :: ParseMode
parseMode = ParseMode
defaultParseMode
{ fixities :: Maybe [Fixity]
fixities = Maybe [Fixity]
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) = (CodeBlock -> Bool) -> [CodeBlock] -> ([CodeBlock], [CodeBlock])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\CodeBlock
cb -> String
i String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` (CodeBlock
cb CodeBlock
-> Getting (Set String) CodeBlock (Set String) -> Set String
forall s a. s -> Getting a s a -> a
^. Getting (Set String) CodeBlock (Set String)
Lens' CodeBlock (Set String)
codeBlockBindings)) [CodeBlock]
blocks
in [CodeBlock]
ins [CodeBlock] -> [CodeBlock] -> [CodeBlock]
forall a. [a] -> [a] -> [a]
++ [String] -> [CodeBlock] -> [CodeBlock]
tc ([String]
is [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (CodeBlock -> [String]) -> [CodeBlock] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Set String -> [String]
forall a. Set a -> [a]
S.toList (Set String -> [String])
-> (CodeBlock -> Set String) -> CodeBlock -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Set String) CodeBlock (Set String)
-> CodeBlock -> Set String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Set String) CodeBlock (Set String)
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 DiagramURL -> Getting String DiagramURL String -> String
forall s a. s -> Getting a s a -> a
^. Getting String DiagramURL String
Lens' DiagramURL String
diagramName) String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set String
ds = (DiagramURL, Bool) -> WriterT [String] IO (DiagramURL, Bool)
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (DiagramURL
url DiagramURL -> Getting String DiagramURL String -> String
forall s a. s -> Getting a s a -> a
^. Getting String DiagramURL String
Lens' DiagramURL String
diagramName)) String -> String -> String
<.> String
"svg"
munge :: String -> String
munge = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_" ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitDirectories (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
normalise (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dropExtension
w, h :: Maybe Double
w :: Maybe Double
w = String -> Double
forall a. Read a => String -> a
read (String -> Double) -> Maybe String -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
"width" (DiagramURL
url DiagramURL
-> Getting (Map String String) DiagramURL (Map String String)
-> Map String String
forall s a. s -> Getting a s a -> a
^. Getting (Map String String) DiagramURL (Map String String)
Lens' DiagramURL (Map String String)
diagramOpts)
h :: Maybe Double
h = String -> Double
forall a. Read a => String -> a
read (String -> Double) -> Maybe String -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
"height" (DiagramURL
url DiagramURL
-> Getting (Map String String) DiagramURL (Map String String)
-> Map String String
forall s a. s -> Getting a s a -> a
^. Getting (Map String String) DiagramURL (Map String String)
Lens' DiagramURL (Map String String)
diagramOpts)
oldURL :: (DiagramURL, Bool)
oldURL = (DiagramURL
url, Bool
False)
newURL :: String -> (DiagramURL, Bool)
newURL String
content = (DiagramURL
url DiagramURL -> (DiagramURL -> DiagramURL) -> DiagramURL
forall a b. a -> (a -> b) -> b
& (String -> Identity String) -> DiagramURL -> Identity DiagramURL
Lens' DiagramURL String
diagramURL ((String -> Identity String) -> DiagramURL -> Identity DiagramURL)
-> String -> DiagramURL -> DiagramURL
forall s t a b. ASetter s t a b -> b -> s -> t
.~ String
content, String
content String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= DiagramURL
urlDiagramURL -> Getting String DiagramURL String -> String
forall s a. s -> Getting a s a -> a
^.Getting String DiagramURL String
Lens' DiagramURL String
diagramURL)
neededCode :: [CodeBlock]
neededCode = String -> [CodeBlock] -> [CodeBlock]
transitiveClosure (DiagramURL
url DiagramURL -> Getting String DiagramURL String -> String
forall s a. s -> Getting a s a -> a
^. Getting String DiagramURL String
Lens' DiagramURL String
diagramName) [CodeBlock]
code
errHeader :: String
errHeader = String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (DiagramURL
url DiagramURL -> Getting String DiagramURL String -> String
forall s a. s -> Getting a s a -> a
^. Getting String DiagramURL String
Lens' DiagramURL String
diagramName) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n"
BuildResult SVG V2 Double
res <- IO (BuildResult SVG V2 Double)
-> WriterT [String] IO (BuildResult SVG V2 Double)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (BuildResult SVG V2 Double)
-> WriterT [String] IO (BuildResult SVG V2 Double))
-> IO (BuildResult SVG V2 Double)
-> WriterT [String] IO (BuildResult SVG V2 Double)
forall a b. (a -> b) -> a -> b
$ do
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
cacheDir
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
dataURIs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
outputDir
String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"[ ] " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (DiagramURL
url DiagramURL -> Getting String DiagramURL String -> String
forall s a. s -> Getting a s a -> a
^. Getting String DiagramURL String
Lens' DiagramURL String
diagramName)
Handle -> IO ()
IO.hFlush Handle
IO.stdout
let
bopts :: DB.BuildOpts SVG V2 Double
bopts :: BuildOpts SVG V2 Double
bopts = SVG
-> V2 Double -> Options SVG V2 Double -> BuildOpts SVG V2 Double
forall b (v :: * -> *) n.
b -> v n -> Options b v n -> BuildOpts b v n
DB.mkBuildOpts SVG
SVG V2 Double
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero (SizeSpec V2 Double
-> Maybe Element
-> Text
-> [Attribute]
-> Bool
-> Options SVG V2 Double
forall n.
SizeSpec V2 n
-> Maybe Element -> Text -> [Attribute] -> Bool -> Options SVG V2 n
SVGOptions (Maybe Double -> Maybe Double -> SizeSpec V2 Double
forall n. Num n => Maybe n -> Maybe n -> SizeSpec V2 n
mkSizeSpec2D Maybe Double
w Maybe Double
h) Maybe Element
forall a. Maybe a
Nothing Text
"" [] Bool
False)
BuildOpts SVG V2 Double
-> (BuildOpts SVG V2 Double -> BuildOpts SVG V2 Double)
-> BuildOpts SVG V2 Double
forall a b. a -> (a -> b) -> b
& ([String] -> Identity [String])
-> BuildOpts SVG V2 Double -> Identity (BuildOpts SVG V2 Double)
forall b (v :: * -> *) n. Lens' (BuildOpts b v n) [String]
DB.snippets (([String] -> Identity [String])
-> BuildOpts SVG V2 Double -> Identity (BuildOpts SVG V2 Double))
-> [String] -> BuildOpts SVG V2 Double -> BuildOpts SVG V2 Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (CodeBlock -> String) -> [CodeBlock] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Getting String CodeBlock String -> CodeBlock -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String CodeBlock String
Lens' CodeBlock String
codeBlockCode) [CodeBlock]
neededCode
BuildOpts SVG V2 Double
-> (BuildOpts SVG V2 Double -> BuildOpts SVG V2 Double)
-> BuildOpts SVG V2 Double
forall a b. a -> (a -> b) -> b
& ([String] -> Identity [String])
-> BuildOpts SVG V2 Double -> Identity (BuildOpts SVG V2 Double)
forall b (v :: * -> *) n. Lens' (BuildOpts b v n) [String]
DB.imports (([String] -> Identity [String])
-> BuildOpts SVG V2 Double -> Identity (BuildOpts SVG V2 Double))
-> [String] -> BuildOpts SVG V2 Double -> BuildOpts SVG V2 Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ String
"Diagrams.Backend.SVG" ]
BuildOpts SVG V2 Double
-> (BuildOpts SVG V2 Double -> BuildOpts SVG V2 Double)
-> BuildOpts SVG V2 Double
forall a b. a -> (a -> b) -> b
& (String -> Identity String)
-> BuildOpts SVG V2 Double -> Identity (BuildOpts SVG V2 Double)
forall b (v :: * -> *) n. Lens' (BuildOpts b v n) String
DB.diaExpr ((String -> Identity String)
-> BuildOpts SVG V2 Double -> Identity (BuildOpts SVG V2 Double))
-> String -> BuildOpts SVG V2 Double -> BuildOpts SVG V2 Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (DiagramURL
url DiagramURL -> Getting String DiagramURL String -> String
forall s a. s -> Getting a s a -> a
^. Getting String DiagramURL String
Lens' DiagramURL String
diagramName)
BuildOpts SVG V2 Double
-> (BuildOpts SVG V2 Double -> BuildOpts SVG V2 Double)
-> BuildOpts SVG V2 Double
forall a b. a -> (a -> b) -> b
& ((Int
-> IO (Maybe (Options SVG V2 Double -> Options SVG V2 Double)))
-> Identity
(Int
-> IO (Maybe (Options SVG V2 Double -> Options SVG V2 Double))))
-> BuildOpts SVG V2 Double -> Identity (BuildOpts SVG V2 Double)
forall b (v :: * -> *) n.
Lens'
(BuildOpts b v n)
(Int -> IO (Maybe (Options b v n -> Options b v n)))
DB.decideRegen (((Int
-> IO (Maybe (Options SVG V2 Double -> Options SVG V2 Double)))
-> Identity
(Int
-> IO (Maybe (Options SVG V2 Double -> Options SVG V2 Double))))
-> BuildOpts SVG V2 Double -> Identity (BuildOpts SVG V2 Double))
-> (Int
-> IO (Maybe (Options SVG V2 Double -> Options SVG V2 Double)))
-> BuildOpts SVG V2 Double
-> BuildOpts SVG V2 Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ((String -> Options SVG V2 Double -> Options SVG V2 Double)
-> String
-> Int
-> IO (Maybe (Options SVG V2 Double -> Options SVG V2 Double))
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)
BuildOpts SVG V2 Double -> IO (BuildResult SVG V2 Double)
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
[String] -> WriterT [String] IO ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
errHeader String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Parse error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err]
String -> WriterT [String] IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logResult String
"!"
(DiagramURL, Bool) -> WriterT [String] IO (DiagramURL, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (DiagramURL, Bool)
oldURL
DB.InterpErr InterpreterError
ierr -> do
[String] -> WriterT [String] IO ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
errHeader String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Interpreter error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ InterpreterError -> String
DB.ppInterpError InterpreterError
ierr]
String -> WriterT [String] IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logResult String
"!"
(DiagramURL, Bool) -> WriterT [String] IO (DiagramURL, Bool)
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)
Bool -> WriterT [String] IO () -> WriterT [String] IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
dataURIs) (WriterT [String] IO () -> WriterT [String] IO ())
-> WriterT [String] IO () -> WriterT [String] IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> WriterT [String] IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WriterT [String] IO ())
-> IO () -> WriterT [String] IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
copyFile String
cached String
outFile
String -> WriterT [String] IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logResult String
"."
if Bool
dataURIs
then do
ByteString
svgBS <- IO ByteString -> WriterT [String] IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> WriterT [String] IO ByteString)
-> IO ByteString -> WriterT [String] IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
cached
(DiagramURL, Bool) -> WriterT [String] IO (DiagramURL, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> (DiagramURL, Bool)
newURL (ByteString -> String
mkDataURI ByteString
svgBS))
else (DiagramURL, Bool) -> WriterT [String] IO (DiagramURL, Bool)
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
Element
svg
IO () -> WriterT [String] IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WriterT [String] IO ())
-> IO () -> WriterT [String] IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BS.writeFile String
cached ByteString
svgBS
(DiagramURL, Bool)
url' <- if Bool
dataURIs
then (DiagramURL, Bool) -> WriterT [String] IO (DiagramURL, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> (DiagramURL, Bool)
newURL (ByteString -> String
mkDataURI ByteString
svgBS))
else IO (DiagramURL, Bool) -> WriterT [String] IO (DiagramURL, Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> String -> IO ()
copyFile String
cached String
outFile IO () -> IO (DiagramURL, Bool) -> IO (DiagramURL, Bool)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DiagramURL, Bool) -> IO (DiagramURL, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> (DiagramURL, Bool)
newURL String
outFile))
String -> WriterT [String] IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logResult String
"X"
(DiagramURL, Bool) -> WriterT [String] IO (DiagramURL, Bool)
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," String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BS8.unpack (ByteString -> ByteString
BS64.encode ByteString
svg)
logStr, logResult :: MonadIO m => String -> m ()
logStr :: String -> m ()
logStr = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
quiet) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStr
logResult :: String -> m ()
logResult String
s = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (IO () -> IO ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
quiet) (IO () -> m ()) -> IO () -> m ()
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 [Either String DiagramURL]
-> ([Either String DiagramURL]
-> WriterT [String] IO [Either String (DiagramURL, Bool)])
-> WriterT [String] IO [Either String (DiagramURL, Bool)]
forall a b. a -> (a -> b) -> b
& ((Either String DiagramURL
-> WriterT [String] IO (Either String (DiagramURL, Bool)))
-> [Either String DiagramURL]
-> WriterT [String] IO [Either String (DiagramURL, Bool)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Either String DiagramURL
-> WriterT [String] IO (Either String (DiagramURL, Bool)))
-> [Either String DiagramURL]
-> WriterT [String] IO [Either String (DiagramURL, Bool)])
-> ((DiagramURL -> WriterT [String] IO (DiagramURL, Bool))
-> Either String DiagramURL
-> WriterT [String] IO (Either String (DiagramURL, Bool)))
-> (DiagramURL -> WriterT [String] IO (DiagramURL, Bool))
-> [Either String DiagramURL]
-> WriterT [String] IO [Either String (DiagramURL, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DiagramURL -> WriterT [String] IO (DiagramURL, Bool))
-> Either String DiagramURL
-> WriterT [String] IO (Either String (DiagramURL, Bool))
forall c a b. Prism (Either c a) (Either c b) a b
_Right)
((DiagramURL -> WriterT [String] IO (DiagramURL, Bool))
-> [Either String DiagramURL]
-> WriterT [String] IO [Either String (DiagramURL, Bool)])
-> (DiagramURL -> WriterT [String] IO (DiagramURL, Bool))
-> [Either String DiagramURL]
-> WriterT [String] IO [Either String (DiagramURL, Bool)]
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 = Getting Any [Either String (DiagramURL, Bool)] Bool
-> [Either String (DiagramURL, Bool)] -> Bool
forall s. Getting Any s Bool -> s -> Bool
orOf ((Either String (DiagramURL, Bool)
-> Const Any (Either String (DiagramURL, Bool)))
-> [Either String (DiagramURL, Bool)]
-> Const Any [Either String (DiagramURL, Bool)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Either String (DiagramURL, Bool)
-> Const Any (Either String (DiagramURL, Bool)))
-> [Either String (DiagramURL, Bool)]
-> Const Any [Either String (DiagramURL, Bool)])
-> ((Bool -> Const Any Bool)
-> Either String (DiagramURL, Bool)
-> Const Any (Either String (DiagramURL, Bool)))
-> Getting Any [Either String (DiagramURL, Bool)] Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DiagramURL, Bool) -> Const Any (DiagramURL, Bool))
-> Either String (DiagramURL, Bool)
-> Const Any (Either String (DiagramURL, Bool))
forall c a b. Prism (Either c a) (Either c b) a b
_Right (((DiagramURL, Bool) -> Const Any (DiagramURL, Bool))
-> Either String (DiagramURL, Bool)
-> Const Any (Either String (DiagramURL, Bool)))
-> ((Bool -> Const Any Bool)
-> (DiagramURL, Bool) -> Const Any (DiagramURL, Bool))
-> (Bool -> Const Any Bool)
-> Either String (DiagramURL, Bool)
-> Const Any (Either String (DiagramURL, Bool))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Const Any Bool)
-> (DiagramURL, Bool) -> Const Any (DiagramURL, Bool)
forall s t a b. Field2 s t a b => Lens s t a b
_2) [Either String (DiagramURL, Bool)]
urls'
([Either String DiagramURL], Bool)
-> WriterT [String] IO ([Either String DiagramURL], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either String (DiagramURL, Bool)]
urls' [Either String (DiagramURL, Bool)]
-> ([Either String (DiagramURL, Bool)]
-> [Either String DiagramURL])
-> [Either String DiagramURL]
forall a b. a -> (a -> b) -> b
& ((Either String (DiagramURL, Bool)
-> Identity (Either String DiagramURL))
-> [Either String (DiagramURL, Bool)]
-> Identity [Either String DiagramURL]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Either String (DiagramURL, Bool)
-> Identity (Either String DiagramURL))
-> [Either String (DiagramURL, Bool)]
-> Identity [Either String DiagramURL])
-> (((DiagramURL, Bool) -> Identity DiagramURL)
-> Either String (DiagramURL, Bool)
-> Identity (Either String DiagramURL))
-> ((DiagramURL, Bool) -> Identity DiagramURL)
-> [Either String (DiagramURL, Bool)]
-> Identity [Either String DiagramURL]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DiagramURL, Bool) -> Identity DiagramURL)
-> Either String (DiagramURL, Bool)
-> Identity (Either String DiagramURL)
forall c a b. Prism (Either c a) (Either c b) a b
_Right) (((DiagramURL, Bool) -> Identity DiagramURL)
-> [Either String (DiagramURL, Bool)]
-> Identity [Either String DiagramURL])
-> ((DiagramURL, Bool) -> DiagramURL)
-> [Either String (DiagramURL, Bool)]
-> [Either String DiagramURL]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (DiagramURL, Bool) -> DiagramURL
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 -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"Error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file String -> String -> String
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) -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
msgs
(Just ([CodeBlock]
cs, Set String
ds), [String]
msgs) ->
case Parser [Either String DiagramURL]
-> String -> String -> Either ParseError [Either String DiagramURL]
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
_ ->
String -> IO [String]
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) <- WriterT [String] IO ([Either String DiagramURL], Bool)
-> IO (([Either String DiagramURL], Bool), [String])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [String] IO ([Either String DiagramURL], Bool)
-> IO (([Either String DiagramURL], Bool), [String]))
-> WriterT [String] IO ([Either String DiagramURL], Bool)
-> IO (([Either String DiagramURL], Bool), [String])
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'
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
changed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => String -> ByteString -> m ()
UIO.writeBinaryFileDurableAtomic String
file (Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
src')
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
msgs [String] -> [String] -> [String]
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 IO String
-> (String -> IO (Maybe ([CodeBlock], Set String), [String]))
-> IO (Maybe ([CodeBlock], Set String), [String])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe ([CodeBlock], Set String), [String])
-> IO (Maybe ([CodeBlock], Set String), [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe ([CodeBlock], Set String), [String])
-> IO (Maybe ([CodeBlock], Set String), [String]))
-> (String -> (Maybe ([CodeBlock], Set String), [String]))
-> String
-> IO (Maybe ([CodeBlock], Set String), [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CollectErrors (Maybe ([CodeBlock], Set String))
-> (Maybe ([CodeBlock], Set String), [String])
forall a. CollectErrors a -> (a, [String])
runCE (CollectErrors (Maybe ([CodeBlock], Set String))
-> (Maybe ([CodeBlock], Set String), [String]))
-> (String -> CollectErrors (Maybe ([CodeBlock], Set String)))
-> String
-> (Maybe ([CodeBlock], Set String), [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> CollectErrors (Maybe ([CodeBlock], Set String))
parseCodeBlocks String
file
| Bool
otherwise = (Maybe ([CodeBlock], Set String), [String])
-> IO (Maybe ([CodeBlock], Set String), [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe ([CodeBlock], Set String), [String])
-> IO (Maybe ([CodeBlock], Set String), [String]))
-> (Maybe ([CodeBlock], Set String), [String])
-> IO (Maybe ([CodeBlock], Set String), [String])
forall a b. (a -> b) -> a -> b
$ CollectErrors (Maybe ([CodeBlock], Set String))
-> (Maybe ([CodeBlock], Set String), [String])
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 Extension -> [Extension] -> Bool
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