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.Applicative hiding (many, (<|>))
import Control.Arrow (first, (&&&), (***))
import Control.Lens hiding ((<.>))
import Control.Monad.Writer
import qualified Data.ByteString.Lazy as BS
import Data.Char (isSpace)
import Data.Either (lefts, rights)
import Data.Function (on)
import Data.Generics.Uniplate.Data (universeBi)
import Data.List (groupBy, intercalate,
isPrefixOf, partition)
import Data.List.Split (dropBlanks, dropDelims, split,
whenElt)
import qualified Data.Map as M
import Data.Maybe (catMaybes, mapMaybe)
import qualified Data.Set as S
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as T
import Data.VectorSpace (zeroV)
import Language.Haskell.Exts.Annotated hiding (loc)
import qualified Language.Haskell.Exts.Annotated as HSE
import Language.Preprocessor.Cpphs
import System.Directory (copyFile,
createDirectoryIfMissing,
doesFileExist)
import System.FilePath ((<.>), (</>))
import qualified System.IO as IO
import qualified System.IO.Cautious as Cautiously
import qualified System.IO.Strict as Strict
import Text.Blaze.Svg.Renderer.Utf8 (renderSvg)
import Text.Parsec
import qualified Text.Parsec as P
import Text.Parsec.String
import Diagrams.Backend.SVG (Options (..), SVG (..))
import Diagrams.Builder (BuildResult (..),
buildDiagram,
hashedRegenerate,
ppInterpError)
import Diagrams.TwoD.Size (mkSizeSpec)
showParseFailure :: SrcLoc -> String -> String
showParseFailure loc err = unlines [ prettyPrint loc, err ]
newtype CollectErrors a = CE { unCE :: Writer [String] a }
deriving (Functor, Applicative, Monad, MonadWriter [String])
failWith :: String -> CollectErrors (Maybe a)
failWith err = tell [err] >> return Nothing
runCE :: CollectErrors a -> (a, [String])
runCE = runWriter . unCE
data DiagramURL = DiagramURL
{ _diagramURL :: String
, _diagramName :: String
, _diagramOpts :: M.Map String String
}
deriving (Show, Eq)
makeLenses ''DiagramURL
displayDiagramURL :: DiagramURL -> String
displayDiagramURL d = "<<" ++ d ^. diagramURL ++ "#" ++ opts ++ ">>"
where
opts = intercalate "&"
. map displayOpt
. (("diagram", d ^. diagramName) :)
. M.assocs
$ d ^. diagramOpts
displayOpt (k,v) = k ++ "=" ++ v
parseDiagramURL :: Parser DiagramURL
parseDiagramURL =
DiagramURL
<$> (string "<<" *> many1 (noneOf "#>"))
<*> (char '#' *> string "diagram=" *> many1 (noneOf "&>"))
<*> ((M.fromList <$> many parseKeyValPair) <* string ">>")
parseKeyValPair :: Parser (String,String)
parseKeyValPair =
char '&' *>
((,) <$> (many1 (noneOf "&>=") <* char '=') <*> many1 (noneOf "&>="))
maybeParseDiagramURL :: Parser (Either Char DiagramURL)
maybeParseDiagramURL =
Right <$> try parseDiagramURL
<|> Left <$> anyChar
parseDiagramURLs :: Parser [Either String DiagramURL]
parseDiagramURLs = condenseLefts <$> many maybeParseDiagramURL
where
condenseLefts :: [Either a b] -> [Either [a] b]
condenseLefts [] = []
condenseLefts (Right a : xs) = Right a : condenseLefts xs
condenseLefts xs = Left (lefts ls) : condenseLefts xs'
where (ls,xs') = span isLeft xs
isLeft (Left {}) = True
isLeft _ = False
displayDiagramURLs :: [Either String DiagramURL] -> String
displayDiagramURLs = concatMap (either id displayDiagramURL)
getDiagramNames :: Comment -> S.Set String
getDiagramNames (Comment _ _ s) =
case P.parse parseDiagramURLs "" s of
Left _ -> error "This case can never happen; see prop_parseDiagramURLs_succeeds"
Right urls -> S.fromList . map (view diagramName) . rights $ urls
coalesceComments :: [Comment] -> [(String, Int)]
coalesceComments
= map (unlines . map getComment &&& commentLine . head)
. map (map fst)
. concatMap (groupBy ((==) `on` snd))
. map (zipWith (\i c -> (c, commentLine c i)) [1..])
. concatMap (\xs -> if isMultiLine (head xs) then map (:[]) xs else [xs])
. groupBy ((==) `on` isMultiLine)
where
isMultiLine (Comment b _ _) = b
getComment (Comment _ _ c) = c
commentLine (Comment _ s _) = srcSpanStartLine s
data CodeBlock
= CodeBlock
{ _codeBlockCode :: String
, _codeBlockIdents :: S.Set String
, _codeBlockBindings :: S.Set String
}
deriving (Show, Eq)
makeLenses ''CodeBlock
makeCodeBlock :: FilePath -> (String,Int) -> CollectErrors (Maybe CodeBlock)
makeCodeBlock file (s,l) =
case HSE.parseFileContentsWithMode parseMode s of
ParseOk m -> return . Just $ CodeBlock s
(collectIdents m)
(collectBindings m)
ParseFailed loc err -> failWith . unlines $
[ file ++ ": " ++ show l ++ ": Warning: could not parse code block:" ]
++
showBlock s
++
[ "Error was:" ]
++
(indent 2 . lines $ showParseFailure loc err)
where
parseMode = defaultParseMode
{ fixities = Nothing
, extensions = MultiParamTypeClasses : haskell2010
}
indent n = map (replicate n ' ' ++)
showBlock b
| length ls > 5 = indent 2 (take 4 ls ++ ["..."])
| otherwise = indent 2 ls
where ls = lines b
collectBindings :: Module l -> S.Set String
collectBindings (Module _ _ _ _ decls) = S.fromList $ mapMaybe getBinding decls
collectBindings _ = S.empty
getBinding :: Decl l -> Maybe String
getBinding (FunBind _ []) = Nothing
getBinding (FunBind _ (Match _ nm _ _ _ : _)) = Just $ getName nm
getBinding (PatBind _ (PVar _ nm) _ _ _) = Just $ getName nm
getBinding _ = Nothing
getName :: Name l -> String
getName (Ident _ s) = s
getName (Symbol _ s) = s
getQName :: QName l -> Maybe String
getQName (Qual _ _ n) = Just $ getName n
getQName (UnQual _ n) = Just $ getName n
getQName _ = Nothing
collectIdents :: Module SrcSpanInfo -> S.Set String
collectIdents m = S.fromList . catMaybes $
[ getQName n
| (Var _ n :: Exp SrcSpanInfo) <- universeBi m
]
extractCodeBlocks :: FilePath -> (String,Int) -> CollectErrors [CodeBlock]
extractCodeBlocks file (s,l)
= fmap catMaybes
. mapM (makeCodeBlock file . (unlines***head) . unzip . (map.first) (drop 2 . dropWhile isSpace))
. (split . dropBlanks . dropDelims $ whenElt (not . isBird . fst))
. flip zip [l ..]
. lines
$ s
where
isBird = ((||) <$> (">"==) <*> ("> " `isPrefixOf`)) . dropWhile isSpace
parseCodeBlocks :: FilePath -> String -> CollectErrors (Maybe ([CodeBlock], S.Set String))
parseCodeBlocks file src =
case HSE.parseFileContentsWithComments parseMode src of
ParseFailed loc err -> failWith $ showParseFailure loc err
ParseOk (_, cs) -> do
blocks <- fmap concat
. mapM (extractCodeBlocks file)
. coalesceComments
$ cs
let diaNames = S.unions . map getDiagramNames $ cs
return . Just $ (blocks, diaNames)
where
parseMode = defaultParseMode
{ fixities = Nothing
, parseFilename = file
, extensions = MultiParamTypeClasses : haskell2010
}
transitiveClosure :: String -> [CodeBlock] -> [CodeBlock]
transitiveClosure ident blocks = tc [ident] blocks
where
tc _ [] = []
tc [] _ = []
tc (i:is) blocks =
let (ins,outs) = partition (\cb -> i `S.member` (cb ^. codeBlockBindings)) blocks
in ins ++ tc (is ++ concatMap (S.toList . view codeBlockIdents) ins) outs
compileDiagram :: Bool
-> FilePath
-> FilePath
-> S.Set String
-> [CodeBlock] -> DiagramURL -> IO (DiagramURL, Bool)
compileDiagram quiet cacheDir outputDir ds code url
| (url ^. diagramName) `S.notMember` ds = return (url, False)
| otherwise = do
createDirectoryIfMissing True outputDir
createDirectoryIfMissing True cacheDir
let outFile = outputDir </> (url ^. diagramName) <.> "svg"
w = read <$> M.lookup "width" (url ^. diagramOpts)
h = read <$> M.lookup "height" (url ^. diagramOpts)
oldURL = (url, False)
newURL = (url & diagramURL .~ outFile, outFile /= url^.diagramURL)
neededCode = transitiveClosure (url ^. diagramName) code
logStr $ (url ^. diagramName) ++ "..."
IO.hFlush IO.stdout
res <- buildDiagram
SVG
zeroV
(SVGOptions (mkSizeSpec w h))
(map (view codeBlockCode) neededCode)
(url ^. diagramName)
[]
[ "Diagrams.Backend.SVG" ]
(hashedRegenerate (\_ opts -> opts) cacheDir)
case res of
ParseErr err -> do
putStrLn ("Parse error:")
putStrLn err
return oldURL
InterpErr ierr -> do
putStrLn ("Interpreter error:")
putStrLn (ppInterpError ierr)
return oldURL
Skipped hash -> do
copyFile (mkCached hash) outFile
logStrLn ""
return newURL
OK hash svg -> do
let cached = mkCached hash
BS.writeFile cached (renderSvg svg)
copyFile cached outFile
logStrLn "compiled."
return newURL
where
mkCached base = cacheDir </> base <.> "svg"
logStr = when (not quiet) . putStr
logStrLn = when (not quiet) . putStrLn
compileDiagrams :: Bool
-> FilePath
-> FilePath
-> S.Set String
-> [CodeBlock]
-> [Either String DiagramURL] -> IO ([Either String DiagramURL], Bool)
compileDiagrams quiet cacheDir outputDir ds cs urls = do
urls' <- urls & (traverse . _Right)
%%~ compileDiagram quiet cacheDir outputDir ds cs
let changed = orOf (traverse . _Right . _2) urls'
return (urls' & (traverse . _Right) %~ fst, changed)
processHaddockDiagrams
:: Bool
-> FilePath
-> FilePath
-> FilePath
-> IO [String]
processHaddockDiagrams = processHaddockDiagrams' opts
where
opts = defaultCpphsOptions
{ boolopts = defaultBoolOptions { hashline = False } }
processHaddockDiagrams'
:: CpphsOptions
-> Bool
-> FilePath
-> FilePath
-> FilePath
-> IO [String]
processHaddockDiagrams' opts quiet cacheDir outputDir file = do
e <- doesFileExist file
case e of
False -> return ["Error: " ++ file ++ " not found."]
True -> do
h <- IO.openFile file IO.ReadMode
IO.hSetEncoding h IO.utf8
src <- Strict.hGetContents h
r <- go src
case r of
(Nothing, msgs) -> return msgs
(Just (cs, ds), msgs) ->
case P.parse parseDiagramURLs "" src of
Left _ ->
error "This case can never happen; see prop_parseDiagramURLs_succeeds"
Right urls -> do
(urls', changed) <- compileDiagrams quiet cacheDir outputDir ds cs urls
let src' = displayDiagramURLs urls'
when changed $ Cautiously.writeFileL file (T.encodeUtf8 . T.pack $ src')
return msgs
where
go src =
case runCE (parseCodeBlocks file src) of
r@(Nothing, msgs) -> if any (("Parse error: #" `elem`) . lines) msgs
then runCpp src >>= return . runCE . parseCodeBlocks file
else return r
r -> return r
runCpp s = runCpphs opts file s