{-# LANGUAGE OverloadedStrings #-}-- Copyright (C) 2010-2011 John Millikin <jmillikin@gmail.com>---- This program is free software: you can redistribute it and/or modify-- it under the terms of the GNU General Public License as published by-- the Free Software Foundation, either version 3 of the License, or-- any later version.---- This program is distributed in the hope that it will be useful,-- but WITHOUT ANY WARRANTY; without even the implied warranty of-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the-- GNU General Public License for more details.---- You should have received a copy of the GNU General Public License-- along with this program. If not, see <http://www.gnu.org/licenses/>.moduleAnansi.Tangle(tangle)whereimportPreludehiding(FilePath)importControl.Monad(when)importqualifiedControl.Monad.StateasSimportqualifiedControl.Monad.RWSasRWSimportqualifiedData.ByteString.Char8asByteStringimportData.ByteString.Char8(ByteString)importqualifiedData.MapimportData.Map(Map)importqualifiedData.TextimportData.Text(Text)importData.Text.Encoding(encodeUtf8)importqualifiedText.ParsecasPimportFilesystem.Path(FilePath)importqualifiedFilesystem.Path.CurrentOSasFPimportAnansi.Types-- macro definitions, #line pragma formattertypeContentMap=MapText[Content]dataTangleEnv=TangleEnvContentMap(Position->Text)-- current position, current indentdataTangleState=TangleStatePositionByteStringtypeTangleT=RWS.RWSTTangleEnvByteStringTangleStatebuildMacros::[Block]->ContentMapbuildMacrosblocks=S.execState(mapM_accumMacroblocks)Data.Map.emptyaccumMacro::Block->S.StateContentMap()accumMacrob=casebofBlockText_->return()BlockFile__->return()BlockDefinenamecontent->domacros<-S.getS.put(Data.Map.insertWith(\newold->old++new)namecontentmacros)buildFiles::[Block]->ContentMapbuildFilesblocks=S.execState(mapM_accumFileblocks)Data.Map.emptyaccumFile::Block->S.StateContentMap()accumFileb=casebofBlockText_->return()BlockDefine__->return()BlockFilenamecontent->doletaccumnewold=old++newfiles<-S.getS.put(Data.Map.insertWithaccumnamecontentfiles)-- | Write a 'Document' to files. Paths passed to the file writer are pulled-- directly from the document, so if you need to process them further, that-- logic must be placed in the writer computation.---- In most cases, users will want to write @#line@ pragmas to tangled source,-- so error messages will refer back to the original input files. Haddock does-- not handle these pragmas properly, so disable them when the tangled sources-- will be processed into API documentation.tangle::Monadm=>(FilePath->ByteString->m())-- ^ File writer->Bool-- ^ Enable writing #line declarations->Document->m()tanglewriteFile'enableLinedoc=mapM_putFilefileswhereblocks=documentBlocksdocstate=TangleState(Position""0)""fileMap=buildFilesblocksmacros=buildMacrosblocksfiles=Data.Map.toAscListfileMapputFile(pathT,content)=doletpath=FP.fromTextpathTletenv=TangleEnvmacros(ifenableLinethenformatPositiondocpathelseconst"\n")(_,bytes)<-RWS.evalRWST(mapM_putContentcontent)envstateletstripped=ByteString.dropWhile(=='\n')byteswriteFile'pathstrippedformatPosition::Document->FilePath->Position->TextformatPositiondoc=checkPathwherefmtC="#line ${line} ${quoted-path}"fmtGo="//line ${path}:${line}"defaultOptions=Data.Map.fromList[("anansi.line-pragma-hs",fmtC),("anansi.line-pragma-c",fmtC),("anansi.line-pragma-cxx",fmtC),("anansi.line-pragma-cpp",fmtC),("anansi.line-pragma-cs",fmtC),("anansi.line-pragma-pl",fmtC),("anansi.line-pragma-go",fmtGo)]opts=fmapcompileTemplate(Data.Map.union(documentOptionsdoc)defaultOptions)checkPathpath=caseFP.extensionpathofJustext->caseData.Map.lookup("anansi.line-pragma-"`Data.Text.append`ext)optsofJusttmpl->checkPostmplNothing->const"\n"Nothing->const"\n"checkPostmplpos=formatTemplatetmpl(templateParamspos)templateParamspos=Data.Map.fromList[("line",show(positionLinepos)),("path",Data.Text.unpack(eitheridid(FP.toText(positionFilepos)))),("quoted-path",show(eitheridid(FP.toText(positionFilepos))))]dataTemplateChunk=TemplateChunkConstText|TemplateChunkVarTexttypeTemplate=[TemplateChunk]compileTemplate::Text->TemplatecompileTemplate""=[]compileTemplatetxt=check(P.parseparser""(Data.Text.unpacktxt))wherecheck(Left_)=error"Internal error: compileTemplate failed."check(Righttmpl)=tmplparser=dochunks<-P.many(P.choice[P.trytwodollar,P.tryvar,dollar,text])P.eofreturnchunkstwodollar=do_<-P.string"$$"return(TemplateChunkConst"$")dollar=do_<-P.char'$'return(TemplateChunkConst"$")var=do_<-P.string"${"name<-P.many1(P.satisfy(\c->c=='-'||(c>='a'&&c<='z')))_<-P.char'}'return(TemplateChunkVar(Data.Text.packname))text=dochars<-P.many1(P.satisfy(/='$'))return(TemplateChunkConst(Data.Text.packchars))formatTemplate::Template->MapTextString->TextformatTemplate[]_="\n"formatTemplatechunksvars=Data.Text.concat("\n":mapformatChunkchunks++["\n"])whereformatChunk(TemplateChunkConstt)=tformatChunk(TemplateChunkVarname)=caseData.Map.lookupnamevarsofJustvalue->Data.Text.packvalueNothing->Data.Text.concat["${",name,"}"]putContent::Monadm=>Content->TangleTm()putContent(ContentTextpost)=doTangleState_indent<-RWS.getputPositionposRWS.tellindentRWS.tell(encodeUtf8t)RWS.tell"\n"putContent(ContentMacroposindentname)=addIndentputMacrowhereaddIndentm=doTangleStatelastPosold<-RWS.getRWS.put(TangleStatelastPos(ByteString.appendold(encodeUtf8indent)))_<-mTangleStatenewPos_<-S.getS.put(TangleStatenewPosold)putMacro=doputPositionposlookupMacronamepos>>=mapM_putContentputPosition::Monadm=>Position->TangleTm()putPositionpos=doTangleStatelastPosindent<-RWS.getletexpectedPos=Position(positionFilelastPos)(positionLinelastPos+1)RWS.put(TangleStateposindent)when(pos/=expectedPos)$doTangleEnv_format<-RWS.askRWS.tell(encodeUtf8(formatpos))lookupMacro::Monadm=>Text->Position->TangleTm[Content]lookupMacronamepos=doTangleEnvmacros_<-RWS.askcaseData.Map.lookupnamemacrosofNothing->error(concat["unknown macro ",showname," at ",Data.Text.unpack(eitheridid(FP.toText(positionFilepos))),":",show(positionLinepos)])Justcontent->returncontent