{-# LANGUAGE GeneralizedNewtypeDeriving #-}{-# LANGUAGE ScopedTypeVariables #-}{-# LANGUAGE TemplateHaskell #-}------------------------------------------------------------------------------- |-- Module : Diagrams.Haddock-- Copyright : (c) 2013 diagrams-haddock team (see LICENSE)-- License : BSD-style (see LICENSE)-- Maintainer : diagrams-discuss@googlegroups.com---- Include inline diagrams code in Haddock documentation! For-- example, here is a green circle:---- <<diagrams/greenCircle.svg#diagram=greenCircle&width=200>>---- which was literally produced by this code:---- > greenCircle = circle 1-- > # fc green # pad 1.1---- For a much better example of the use of diagrams-haddock, see the-- diagrams-contrib package: <http://hackage.haskell.org/package/diagrams%2Dcontrib>.---- For complete documentation and examples, see-- <https://github.com/diagrams/diagrams-haddock/blob/master/README.md>.-----------------------------------------------------------------------------moduleDiagrams.Haddock(-- * Diagram URLs-- $urlsDiagramURL(..),displayDiagramURL,parseDiagramURL,parseKeyValPair,maybeParseDiagramURL,parseDiagramURLs,displayDiagramURLs-- * Comments-- $comments,getDiagramNames,coalesceComments-- * Code blocks-- $codeblocks,CodeBlock(..),codeBlockCode,codeBlockIdents,codeBlockBindings,makeCodeBlock,collectBindings,extractCodeBlocks,parseCodeBlocks,transitiveClosure-- * Diagram compilation-- $diagrams,compileDiagram,compileDiagrams,processHaddockDiagrams,processHaddockDiagrams'-- * Utilities,showParseFailure,CollectErrors(..),failWith,runCE)whereimportControl.Applicativehiding(many,(<|>))importControl.Arrow(first,(&&&),(***))importControl.Lenshiding((<.>))importControl.Monad.WriterimportqualifiedData.ByteString.Base64.LazyasBS64importqualifiedData.ByteString.LazyasBSimportqualifiedData.ByteString.Lazy.Char8asBS8importData.Char(isSpace)importData.Either(lefts,rights)importData.Function(on)importData.Generics.Uniplate.Data(universeBi)importData.List(groupBy,intercalate,isPrefixOf,partition)importData.List.Split(dropBlanks,dropDelims,split,whenElt)importqualifiedData.MapasMimportData.Maybe(catMaybes,mapMaybe)importqualifiedData.SetasSimportqualifiedData.Text.LazyasTimportqualifiedData.Text.Lazy.EncodingasTimportData.VectorSpace(zeroV)importLanguage.Haskell.Exts.Annotatedhiding(loc)importqualifiedLanguage.Haskell.Exts.AnnotatedasHSEimportLanguage.Preprocessor.CpphsimportSystem.Console.ANSI(cursorDownLine,setCursorColumn)importSystem.Directory(copyFile,createDirectoryIfMissing,doesFileExist)importSystem.FilePath(dropExtension,normalise,splitDirectories,(<.>),(</>))importqualifiedSystem.IOasIOimportqualifiedSystem.IO.CautiousasCautiouslyimportqualifiedSystem.IO.StrictasStrictimportText.Blaze.Svg.Renderer.Utf8(renderSvg)importText.ParsecimportqualifiedText.ParsecasPimportText.Parsec.StringimportDiagrams.Backend.SVG(Options(..),SVG(..))importDiagrams.Builder(BuildResult(..),buildDiagram,hashedRegenerate,ppInterpError)importDiagrams.TwoD.Size(mkSizeSpec)-------------------------------------------------------------- Utilities------------------------------------------------------------showParseFailure::SrcLoc->String->StringshowParseFailurelocerr=unlines[prettyPrintloc,err]newtypeCollectErrorsa=CE{unCE::Writer[String]a}deriving(Functor,Applicative,Monad,MonadWriter[String])failWith::String->CollectErrors(Maybea)failWitherr=tell[err]>>returnNothingrunCE::CollectErrorsa->(a,[String])runCE=runWriter.unCE-------------------------------------------------------------- Diagram URLs-------------------------------------------------------------- $urls-- Haddock supports inline links to images with the syntax-- @\<\<URL\>\>@. To indicate an image which should be automatically-- generated from some diagrams code, we use the special syntax-- @\<\<URL#diagram=name&key1=val1&key2=val2&...\>\>@. The point is-- that everything following the @#@ will be ignored by browsers, but-- we can use it to indicate to diagrams-haddock the name of the-- diagram to be rendered along with options such as size.-- | An abstract representation of inline Haddock image URLs with-- diagrams tags, like @\<\<URL#diagram=name&width=100\>\>@.dataDiagramURL=DiagramURL{_diagramURL::String,_diagramName::String,_diagramOpts::M.MapStringString}deriving(Show,Eq)makeLenses''DiagramURL-- | Display a diagram URL in the format @\<\<URL#diagram=name&key=val&...\>\>@.displayDiagramURL::DiagramURL->StringdisplayDiagramURLd="<<"++d^.diagramURL++"#"++opts++">>"whereopts=intercalate"&".mapdisplayOpt.(("diagram",d^.diagramName):).M.assocs$d^.diagramOptsdisplayOpt(k,v)=k++"="++v-- | Parse things of the form @\<\<URL#diagram=name&key=val&...\>\>@.-- The URL is optional (the @#@, however, is required).parseDiagramURL::ParserDiagramURLparseDiagramURL=DiagramURL<$>(string"<<"*>many(noneOf"#>"))<*>(char'#'*>string"diagram="*>many1(noneOf"&>"))<*>((M.fromList<$>manyparseKeyValPair)<*string">>")-- | Parse a key/value pair of the form @&key=val@.parseKeyValPair::Parser(String,String)parseKeyValPair=char'&'*>((,)<$>(many1(noneOf"&>=")<*char'=')<*>many1(noneOf"&>="))-- | Parse a diagram URL /or/ a single character which is not the-- start of a diagram URL.maybeParseDiagramURL::Parser(EitherCharDiagramURL)maybeParseDiagramURL=Right<$>tryparseDiagramURL<|>Left<$>anyChar-- | Decompose a string into a parsed form with explicitly represented-- diagram URLs interspersed with other content.parseDiagramURLs::Parser[EitherStringDiagramURL]parseDiagramURLs=condenseLefts<$>manymaybeParseDiagramURLwherecondenseLefts::[Eitherab]->[Either[a]b]condenseLefts[]=[]condenseLefts(Righta:xs)=Righta:condenseLeftsxscondenseLeftsxs=Left(leftsls):condenseLeftsxs'where(ls,xs')=spanisLeftxsisLeft(Left{})=TrueisLeft_=False-- | Serialize a parsed comment with diagram URLs back into a String.displayDiagramURLs::[EitherStringDiagramURL]->StringdisplayDiagramURLs=concatMap(eitheriddisplayDiagramURL)-------------------------------------------------------------- Comments-------------------------------------------------------------- $comments-- A few miscellaneous functions for dealing with comments.-- | Get the names of all diagrams referenced from diagram URLs in the-- given comment.getDiagramNames::Comment->S.SetStringgetDiagramNames(Comment__s)=caseP.parseparseDiagramURLs""sofLeft_->error"This case can never happen; see prop_parseDiagramURLs_succeeds"Righturls->S.fromList.map(viewdiagramName).rights$urls-- | Given a series of comments, return a list of their contents,-- coalescing blocks of adjacent single-line comments into one-- String. Each string will be paired with the number of the line-- on which it begins.coalesceComments::[Comment]->[(String,Int)]coalesceComments=map(unlines.mapgetComment&&&commentLine.head)-- discard no longer needed numbers.map(mapfst)-- group consecutive runs.concatMap(groupBy((==)`on`snd))-- subtract consecutive numbers so runs show up as repeats-- e.g. L1, L2, L3, L6, L7, L9 --> 0,0,0,2,2,3.map(zipWith(\ic->(c,commentLinec-i))[1..])-- explode out each multi-line comment into its own singleton list,-- which will be unaffected by the above shenanigans.concatMap(\xs->ifisMultiLine(headxs)thenmap(:[])xselse[xs])-- group multi + single line comments together.groupBy((==)`on`isMultiLine)whereisMultiLine(Commentb__)=bgetComment(Comment__c)=ccommentLine(Comment_s_)=srcSpanStartLines-- Argh, I really wish the split package supported splitting on a-- predicate over adjacent elements! That would make the above-- soooo much easier.-------------------------------------------------------------- Code blocks-------------------------------------------------------------- $codeblocks-- A code block represents some portion of a comment set off by bird-- tracks. We also collect a list of the names bound in each code-- block, in order to decide which code blocks contain expressions-- representing diagrams that are to be rendered.-- | A @CodeBlock@ represents a portion of a comment which is a valid-- code block (set off by > bird tracks). It also caches the list-- of bindings present in the code block.dataCodeBlock=CodeBlock{_codeBlockCode::String,_codeBlockIdents::S.SetString,_codeBlockBindings::S.SetString}deriving(Show,Eq)makeLenses''CodeBlock-- | Given a @String@ representing a code block, /i.e./ valid Haskell-- code with any bird tracks already stripped off, along with its-- beginning line number (and the name of the file from which it was-- taken), attempt to parse it, extract the list of bindings-- present, and construct a 'CodeBlock' value.makeCodeBlock::FilePath->(String,Int)->CollectErrors(MaybeCodeBlock)makeCodeBlockfile(s,l)=caseHSE.parseFileContentsWithModeparseModesofParseOkm->return.Just$CodeBlocks(collectIdentsm)(collectBindingsm)ParseFailedlocerr->failWith.unlines$[file++": "++showl++":\nWarning: could not parse code block:"]++showBlocks++["Error was:"]++(indent2.lines$showParseFailurelocerr)whereparseMode=defaultParseMode{fixities=Nothing,baseLanguage=Haskell2010,extensions=[EnableExtensionMultiParamTypeClasses]}indentn=map(replicaten' '++)showBlockb|lengthls>5=indent2(take4ls++["..."])|otherwise=indent2lswherels=linesb-- | Collect the list of names bound in a module.collectBindings::Modulel->S.SetStringcollectBindings(Module____decls)=S.fromList$mapMaybegetBindingdeclscollectBindings_=S.emptygetBinding::Decll->MaybeStringgetBinding(FunBind_[])=NothinggetBinding(FunBind_(Match_nm___:_))=Just$getNamenmgetBinding(PatBind_(PVar_nm)___)=Just$getNamenmgetBinding_=NothinggetName::Namel->StringgetName(Ident_s)=sgetName(Symbol_s)=sgetQName::QNamel->MaybeStringgetQName(Qual__n)=Just$getNamengetQName(UnQual_n)=Just$getNamengetQName_=Nothing-- | Collect the list of referenced identifiers in a module.collectIdents::ModuleSrcSpanInfo->S.SetStringcollectIdentsm=S.fromList.catMaybes$[getQNamen|(Var_n::ExpSrcSpanInfo)<-universeBim]-- | From a @String@ representing a comment (along with its beginning-- line number, and the name of the file it came from, for error-- reporting purposes), extract all the code blocks (consecutive-- lines beginning with bird tracks), and error messages for code-- blocks that fail to parse.extractCodeBlocks::FilePath->(String,Int)->CollectErrors[CodeBlock]extractCodeBlocksfile(s,l)=fmapcatMaybes.mapM(makeCodeBlockfile.(unlines***head).unzip.(map.first)(drop2.dropWhileisSpace)).(split.dropBlanks.dropDelims$whenElt(not.isBird.fst)).flipzip[l..].lines$swhereisBird=((||)<$>(">"==)<*>("> "`isPrefixOf`)).dropWhileisSpace-- | Take the contents of a Haskell source file (and the name of the-- file, for error reporting purposes), and extract all the code-- blocks, as well as the referenced diagram names.parseCodeBlocks::FilePath->String->CollectErrors(Maybe([CodeBlock],S.SetString))parseCodeBlocksfilesrc=caseHSE.parseFileContentsWithCommentsparseModesrcofParseFailedlocerr->failWith$showParseFailurelocerrParseOk(_,cs)->doblocks<-fmapconcat.mapM(extractCodeBlocksfile).coalesceComments$csletdiaNames=S.unions.mapgetDiagramNames$csreturn.Just$(blocks,diaNames)whereparseMode=defaultParseMode{fixities=Nothing,parseFilename=file,baseLanguage=Haskell2010,extensions=[EnableExtensionMultiParamTypeClasses]}-- | Given an identifier and a list of CodeBlocks, filter the list of-- CodeBlocks to the transitive closure of the "depends-on"-- relation, /i.e./ only blocks which bind identifiers referenced in-- blocks ultimately needed by the block which defines the desired-- identifier.transitiveClosure::String->[CodeBlock]->[CodeBlock]transitiveClosureidentblocks=tc[ident]blockswheretc_[]=[]tc[]_=[]tc(i:is)blocks=let(ins,outs)=partition(\cb->i`S.member`(cb^.codeBlockBindings))blocksinins++tc(is++concatMap(S.toList.viewcodeBlockIdents)ins)outs-------------------------------------------------------------- Diagrams-------------------------------------------------------------- $diagrams-- This section contains all the functions which actually interface-- with diagrams-builder in order to compile diagrams referenced from-- URLs.-- | Given a directory for cached diagrams and a directory for-- outputting final diagrams, and all the relevant code blocks,-- compile the diagram referenced by a single URL, returning a new-- URL updated to point to the location of the generated diagram.-- Also return a @Bool@ indicating whether the URL changed.---- In particular, the diagram will be output to @outDir/name.svg@,-- where @outDir@ is the second argument to @compileDiagram@, and-- @name@ is the name of the diagram. The updated URL will also-- refer to @outDir/name.svg@, under the assumption that @outDir@-- will be copied into the Haddock output directory. (For-- information on how to make this copying happen, see the README:-- <https://github.com/diagrams/diagrams-haddock/blob/master/README.md>.)-- If for some reason you would like this scheme to be more-- flexible/configurable, feel free to file a feature request.compileDiagram::Bool-- ^ @True@ = quiet->Bool-- ^ @True@ = generate data URIs->FilePath-- ^ cache directory->FilePath-- ^ output directory->FilePath-- ^ file being processed->S.SetString-- ^ diagrams referenced from URLs->[CodeBlock]->DiagramURL->WriterT[String]IO(DiagramURL,Bool)compileDiagramquietdataURIscacheDiroutputDirfiledscodeurl-- See https://github.com/diagrams/diagrams-haddock/issues/7 .|(url^.diagramName)`S.notMember`ds=return(url,False)-- The normal case.|otherwise=doletoutFile=outputDir</>(mungefile++"_"++(url^.diagramName))<.>"svg"munge=intercalate"_".splitDirectories.normalise.dropExtensionw=read<$>M.lookup"width"(url^.diagramOpts)h=read<$>M.lookup"height"(url^.diagramOpts)oldURL=(url,False)newURLcontent=(url&diagramURL.~content,content/=url^.diagramURL)neededCode=transitiveClosure(url^.diagramName)codeerrHeader=file++": "++(url^.diagramName)++":\n"res<-liftIO$docreateDirectoryIfMissingTruecacheDirwhen(notdataURIs)$createDirectoryIfMissingTrueoutputDirlogStr$"[ ] "++(url^.diagramName)IO.hFlushIO.stdoutbuildDiagramSVGzeroV(SVGOptions(mkSizeSpecwh)Nothing)(map(viewcodeBlockCode)neededCode)(url^.diagramName)[]["Diagrams.Backend.SVG"](hashedRegenerate(\_opts->opts)cacheDir)caseresof-- XXX incorporate these into error reporting framework instead of printingParseErrerr->dotell[errHeader++"Parse error: "++err]logResult"!"returnoldURLInterpErrierr->dotell[errHeader++"Interpreter error: "++ppInterpErrorierr]logResult"!"returnoldURLSkippedhash->doletcached=mkCachedhashwhen(notdataURIs)$liftIO$copyFilecachedoutFilelogResult"."ifdataURIsthendosvgBS<-liftIO$BS.readFilecachedreturn(newURL(mkDataURIsvgBS))elsereturn(newURLoutFile)OKhashsvg->doletcached=mkCachedhashsvgBS=renderSvgsvgliftIO$BS.writeFilecachedsvgBSurl'<-ifdataURIsthenreturn(newURL(mkDataURIsvgBS))elseliftIO(copyFilecachedoutFile>>return(newURLoutFile))logResult"X"returnurl'wheremkCachedbase=cacheDir</>base<.>"svg"mkDataURIsvg="data:image/svg+xml;base64,"++BS8.unpack(BS64.encodesvg)logStr,logResult::MonadIOm=>String->m()logStr=liftIO.when(notquiet).putStrlogResults=liftIO.when(notquiet)$dosetCursorColumn1putStrLns-- | Compile all the diagrams referenced in an entire module.compileDiagrams::Bool-- ^ @True@ = quiet->Bool-- ^ @True@ = generate data URIs->FilePath-- ^ cache directory->FilePath-- ^ output directory->FilePath-- ^ file being processed->S.SetString-- ^ diagram names referenced from URLs->[CodeBlock]->[EitherStringDiagramURL]->WriterT[String]IO([EitherStringDiagramURL],Bool)compileDiagramsquietdataURIscacheDiroutputDirfiledscsurls=dourls'<-urls&(traverse._Right)%%~compileDiagramquietdataURIscacheDiroutputDirfiledscsletchanged=orOf(traverse._Right._2)urls'return(urls'&(traverse._Right)%~fst,changed)-- | Read a file, compile all the referenced diagrams, and update all-- the diagram URLs to refer to the proper image files. Note, this-- /overwrites/ the file, so it's recommended to only do this on-- files that are under version control, so you can compare the two-- versions and roll back if 'processHaddockDiagrams' does something-- horrible.---- Returns a list of warnings and/or errors.processHaddockDiagrams::Bool-- ^ quiet->Bool-- ^ generate data URIs?->FilePath-- ^ cache directory->FilePath-- ^ output directory->FilePath-- ^ file to be processed->IO[String]processHaddockDiagrams=processHaddockDiagrams'optswhereopts=defaultCpphsOptions{boolopts=defaultBoolOptions{hashline=False}}-- | Version of 'processHaddockDiagrams' that takes options for @cpphs@.processHaddockDiagrams'::CpphsOptions-- ^ Options for cpphs->Bool-- ^ quiet->Bool-- ^ generate data URIs?->FilePath-- ^ cache directory->FilePath-- ^ output directory->FilePath-- ^ file to be processed->IO[String]processHaddockDiagrams'optsquietdataURIscacheDiroutputDirfile=doe<-doesFileExistfilecaseeofFalse->return["Error: "++file++" not found."]True->do-- always assume UTF-8, to make our lives simpler!h<-IO.openFilefileIO.ReadModeIO.hSetEncodinghIO.utf8src<-Strict.hGetContentshr<-gosrccaserof(Nothing,msgs)->returnmsgs(Just(cs,ds),msgs)->caseP.parseparseDiagramURLs""srcofLeft_->error"This case can never happen; see prop_parseDiagramURLs_succeeds"Righturls->do((urls',changed),msgs2)<-runWriterT$compileDiagramsquietdataURIscacheDiroutputDirfiledscsurlsletsrc'=displayDiagramURLsurls'-- See https://github.com/diagrams/diagrams-haddock/issues/8:-- Cautiously.writeFile truncates chars to 8 bits. So-- we do the encoding to UTF-8 ourselves and then call-- writeFileL.whenchanged$Cautiously.writeFileLfile(T.encodeUtf8.T.pack$src')return(msgs++msgs2)wheregosrc=caserunCE(parseCodeBlocksfilesrc)ofr@(Nothing,msgs)->ifany(("Parse error: #"`elem`).lines)msgsthenrunCppsrc>>=return.runCE.parseCodeBlocksfileelsereturnrr->returnrrunCpps=runCpphsoptsfiles