-- Copyright (C) 2007 David Roundy---- 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 2, or (at your option)-- 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; see the file COPYING. If not, write to-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,-- Boston, MA 02110-1301, USA.{-# OPTIONS_GHC -cpp -fglasgow-exts #-}{-# LANGUAGE CPP #-}-- , TypeOperators, GADTs #-}#include "gadts.h"moduleDarcs.Patch.Patchy(Patchy,Apply,apply,applyAndTryToFix,applyAndTryToFixFL,mapMaybeSnd,Commute(..),commuteFLorComplain,commuteRL,commuteFL,commuteRLFL,mergeFL,toFwdCommute,toRevCommute,ShowPatch(..),ReadPatch,readPatch',bracketedFL,peekfor,Invert(..),invertFL,invertRL)whereimportControl.Monad(liftM)importData.Maybe(fromJust)importData.Word(Word8)importData.List(nub)importStorage.Hashed.Monad(TreeIO)importDarcs.Witnesses.Sealed(Sealed(..),Sealed2(..),seal2)importDarcs.Patch.ReadMonads(ParserM,lexEof,peekInput,myLex,work,alterInput)importDarcs.Witnesses.OrderedimportPrinter(Doc,(<>),text)importDarcs.Lock(writeDocBinFile,gzWriteDocFile)importDarcs.IO(WriteableDirectory)importDarcs.Flags(DarcsFlag)importEnglish(plural,Noun(Noun))importByteStringUtils(ifHeadThenTail,dropSpace)importqualifiedData.ByteString.Char8asBC(pack,ByteString)--import Darcs.ColorPrinter ( traceDoc )--import Printer ( greenText, ($$) )class(Applyp,Commutep,ShowPatchp,ReadPatchp,Invertp)=>Patchypwhere-- instance (ShowPatch p, Invert p) => Patchy p whereclassApplypwhereapply::WriteableDirectorym=>[DarcsFlag]->pC(xy)->m()apply_p=domp'<-applyAndTryToFixpcasemp'ofNothing->return()Just(e,_)->fail$"Unable to apply a patch: "++eapplyAndTryToFix::WriteableDirectorym=>pC(xy)->m(Maybe(String,pC(xy)))applyAndTryToFixp=doapply[]p;returnNothingapplyAndTryToFixFL::WriteableDirectorym=>pC(xy)->m(Maybe(String,FLpC(xy)))applyAndTryToFixFLp=mapMaybeSnd(:>:NilFL)`liftM`applyAndTryToFixpmapMaybeSnd::(a->b)->Maybe(c,a)->Maybe(c,b)mapMaybeSndf(Just(a,b))=Just(a,fb)mapMaybeSnd_Nothing=Nothing-- | Things that can commute.classCommutepwherecommute::(p:>p)C(xy)->Maybe((p:>p)C(xy))merge::(p:\/:p)C(xy)->(p:/\:p)C(xy)listTouchedFiles::pC(xy)->[FilePath]hunkMatches::(BC.ByteString->Bool)->pC(xy)->Bool-- | Swaps the ordered pair type so that commute can be-- called directly.toFwdCommute::(Commutep,Commuteq,Monadm)=>((p:<q)C(xy)->m((q:<p)C(xy)))->(q:>p)C(xy)->m((p:>q)C(xy))toFwdCommutec(x:>y)=dox':<y'<-c(y:<x)return(y':>x')-- | Swaps the ordered pair type from the order expected-- by commute to the reverse order.toRevCommute::(Commutep,Commuteq,Monadm)=>((p:>q)C(xy)->m((q:>p)C(xy)))->(q:<p)C(xy)->m((p:<q)C(xy))toRevCommutec(x:<y)=dox':>y'<-c(y:>x)return(y':<x')classCommutep=>ShowPatchpwhereshowPatch::pC(xy)->DocshowNicely::pC(xy)->DocshowNicely=showPatchshowContextPatch::pC(xy)->TreeIODocshowContextPatchp=return$showPatchpdescription::pC(xy)->Docdescription=showPatchsummary::pC(xy)->Docsummary=showPatchwritePatch::FilePath->pC(xy)->IO()writePatchfp=writeDocBinFilef$showPatchp<>text"\n"gzWritePatch::FilePath->pC(xy)->IO()gzWritePatchfp=gzWriteDocFilef$showPatchp<>text"\n"thing::pC(xy)->Stringthing_="patch"things::pC(xy)->Stringthingsx=plural(Noun$thingx)""classReadPatchpwherereadPatch'::ParserMm=>Bool->m(Maybe(Sealed(pC(x))))classMyEqp=>Invertpwhereinvert::pC(xy)->pC(yx)identity::pC(xx)sloppyIdentity::pC(xy)->EqCheckC(xy)sloppyIdentityp=identity=\/=pinstanceApplyp=>Apply(FLp)whereapply_NilFL=return()applyopts(p:>:ps)=applyoptsp>>applyoptspsapplyAndTryToFixNilFL=returnNothingapplyAndTryToFix(p:>:ps)=domp<-applyAndTryToFixFLpmps<-applyAndTryToFixpsreturn$case(mp,mps)of(Nothing,Nothing)->Nothing(Just(e,p'),Nothing)->Just(e,p'+>+ps)(Nothing,Just(e,ps'))->Just(e,p:>:ps')(Just(e,p'),Just(es,ps'))->Just(unlines[e,es],p'+>+ps')instanceCommutep=>Commute(FLp)wherecommute(NilFL:>x)=Just(x:>NilFL)commute(x:>NilFL)=Just(NilFL:>x)commute(xs:>ys)=doys':>rxs'<-commuteRLFL(reverseFLxs:>ys)return$ys':>reverseRLrxs'merge(NilFL:\/:x)=x:/\:NilFLmerge(x:\/:NilFL)=NilFL:/\:xmerge((x:>:xs):\/:ys)=fromJust$doys':/\:x'<-return$mergeFL(x:\/:ys)xs':/\:ys''<-return$merge(ys':\/:xs)return(ys'':/\:(x':>:xs'))listTouchedFilesxs=nub$concat$mapFLlistTouchedFilesxshunkMatchesf=or.mapFL(hunkMatchesf)mergeFL::Commutep=>(p:\/:FLp)C(xy)->(FLp:/\:p)C(xy)mergeFL(p:\/:NilFL)=NilFL:/\:pmergeFL(p:\/:(x:>:xs))=fromJust$dox':/\:p'<-return$merge(p:\/:x)xs':/\:p''<-return$mergeFL(p':\/:xs)return((x':>:xs'):/\:p'')commuteRLFL::Commutep=>(RLp:>FLp)C(xy)->Maybe((FLp:>RLp)C(xy))commuteRLFL(NilRL:>ys)=Just(ys:>NilRL)commuteRLFL(xs:>NilFL)=Just(NilFL:>xs)commuteRLFL(xs:>y:>:ys)=doy':>xs'<-commuteRL(xs:>y)ys':>xs''<-commuteRLFL(xs':>ys)return(y':>:ys':>xs'')commuteRL::Commutep=>(RLp:>p)C(xy)->Maybe((p:>RLp)C(xy))commuteRL(z:<:zs:>w)=dow':>z'<-commute(z:>w)w'':>zs'<-commuteRL(zs:>w')return(w'':>z':<:zs')commuteRL(NilRL:>w)=Just(w:>NilRL)commuteFLorComplain::Commutep=>(p:>FLp)C(xy)->Either(Sealed2p)((FLp:>p)C(xy))commuteFLorComplain(p:>NilFL)=Right(NilFL:>p)commuteFLorComplain(q:>p:>:ps)=casecommute(q:>p)ofJust(p':>q')->casecommuteFLorComplain(q':>ps)ofRight(ps':>q'')->Right(p':>:ps':>q'')Leftl->LeftlNothing->Left$seal2pcommuteFL::Commutep=>(p:>FLp)C(xy)->Maybe((FLp:>p)C(xy))commuteFL=either(constNothing)Just.commuteFLorComplaininstanceReadPatchp=>ReadPatch(FLp)wherereadPatch'want_eof=Just`liftM`read_patcheswhereread_patches::ParserMm=>m(Sealed(FLpC(x)))read_patches=do--tracePeek "starting FL read"mp<-readPatch'FalsecasempofJust(Sealedp)->do--tracePeek "found one patch"Sealedps<-read_patchesreturn$Sealed(p:>:ps)Nothing->ifwant_eofthendo--tracePeek "no more patches"unit'<-lexEofcaseunit'of()->return$SealedNilFLelsedo--tracePeek "no more patches"return$SealedNilFL-- tracePeek x = do y <- peekInput-- traceDoc (greenText x $$ greenText (show $ sal_to_string y)) return (){-# INLINE bracketedFL #-}bracketedFL::forallpmC(x).(ReadPatchp,ParserMm)=>(FORALL(y)m(Maybe(Sealed(pC(y)))))->Word8->Word8->m(Maybe(Sealed(FLpC(x))))bracketedFLparserprepost=peekforwprebfl(returnNothing)wherebfl::FORALL(z)m(Maybe(Sealed(FLpC(z))))bfl=peekforwpost(return$Just$SealedNilFL)(doJust(Sealedp)<-parserJust(Sealedps)<-bflreturn$Just$Sealed(p:>:ps)){-# INLINE peekforw #-}peekforw::ParserMm=>Word8->ma->ma->mapeekforwwifstrifnot=dos<-peekInputcaseifHeadThenTailw$dropSpacesofJusts'->alterInput(consts')>>ifstrNothing->ifnotpeekforPS::ParserMm=>BC.ByteString->ma->ma->mapeekforPSpsifstrifnot=dos<-peekInputcase((ps==).fst)`fmap`myLexsofJustTrue->workmyLex>>ifstr_->ifnot{-# INLINE peekfor #-}peekfor::ParserMm=>String->ma->ma->mapeekfor=peekforPS.BC.packinstanceApplyp=>Apply(RLp)whereapply_NilRL=return()applyopts(p:<:ps)=applyoptsps>>applyoptspinstanceCommutep=>Commute(RLp)wherecommute(xs:>ys)=dofys':>xs'<-commuteRLFL(xs:>reverseRLys)return(reverseFLfys':>xs')merge(x:\/:y)=casemerge(reverseRLx:\/:reverseRLy)of(ry':/\:rx')->reverseFLry':/\:reverseFLrx'listTouchedFiles=listTouchedFiles.reverseRLhunkMatchesf=hunkMatchesf.reverseRLinstanceReadPatchp=>ReadPatch(RLp)wherereadPatch'want_eof=doJust(Sealedfl)<-readPatch'want_eofreturn$Just$Sealed$reverseFLflinvertFL::Invertp=>FLpC(xy)->RLpC(yx)invertFLNilFL=NilRLinvertFL(x:>:xs)=invertx:<:invertFLxsinvertRL::Invertp=>RLpC(xy)->FLpC(yx)invertRLNilRL=NilFLinvertRL(x:<:xs)=invertx:>:invertRLxs