{-# LANGUAGE CPP, TypeFamilies, NoMonomorphismRestriction, FlexibleInstances, ScopedTypeVariables #-}{- Copyright JP Bernardy 2008 -}-- | Generic syntax tree handling functionsmoduleYi.Syntax.Tree(IsTree(..),toksAfter,allToks,tokAtOrBefore,toksInRegion,sepBy,sepBy1,getLastOffset,getFirstOffset,getFirstElement,getLastElement,getLastPath,getAllSubTrees,tokenBasedAnnots,tokenBasedStrokes,subtreeRegion,fromLeafToLeafAfter,fromNodeToFinal)where-- Some of this might be replaced by a generic package-- such as multirec, uniplace, emgm, ...importPrelude(curry)importControl.Arrow(first)importData.List(dropWhile,takeWhile,reverse,filter,zip,take,drop,length,splitAt)importData.MaybeimportData.Monoid#ifdef TESTINGimportTest.QuickCheck#endifimportYi.Buffer.BasicimportYi.Lexer.AleximportYi.PreludeimportYi.Region-- Fundamental typestypePath=[Int]typeNodet=(Path,t)classFoldabletree=>IsTreetreewhere-- | Direct subtrees of a treesubtrees::treet->[treet]subtrees=fst.uniplateuniplate::treet->([treet],[treet]->treet)emptyNode::treettoksAfter::Foldablet1=>t->t1a->[a]toksAfter_begin=allToksallToks::Foldablet=>ta->[a]allToks=toListtokAtOrBefore::Foldablet=>Point->t(Tokt1)->Maybe(Tokt1)tokAtOrBeforepres=listToMaybe$reverse$toksInRegion(mkRegion0(p+1))restoksInRegion::Foldablet1=>Region->t1(Tokt)->[Tokt]toksInRegionreg=takeWhile(\t->tokBegint<=regionEndreg).dropWhile(\t->tokEndt<regionStartreg).toksAfter(regionStartreg)tokenBasedAnnots::(Foldablet1)=>(a1->Maybea)->t1a1->t->[a]tokenBasedAnnotsttatbegin=catMaybes$fmaptta$toksAfterbeginttokenBasedStrokes::(Foldablet3)=>(a->b)->t3a->t->t2->t1->[b]tokenBasedStrokesttst_pointbegin_end=fmaptts$toksAfterbegint-- | Prune the nodes before the given point.-- The path is used to know which nodes we can force or not.pruneNodesBefore::IsTreetree=>Point->Path->tree(Toka)->tree(Toka)pruneNodesBefore_[]t=tpruneNodesBeforep(x:xs)t=rebuild(left'++pruneNodesBeforepxsc:rights)where(children,rebuild)=uniplatet(left,c:rights)=splitAtxchildrenleft'=fmapreplaceEmptyleftreplaceEmptys=ifgetLastOffsets<pthenemptyNodeelses-- | Given an approximate path to a leaf at the end of the region, return:-- (path to leaf at the end of the region,path from focused node to the leaf, small node encompassing the region)fromNodeToFinal::IsTreetree=>Region->Node(tree(Toka))->Node(tree(Toka))fromNodeToFinalr(xs,root)=trace("r = "++showr)$trace("focused ~ "++show(subtreeRegionfocused))$trace("pathFromFocusedToLeaf = "++showfocusedToLeaf)$trace("pruned ~ "++show(subtreeRegionfocused))$(xs',pruned)wheren@(xs',_)=fromLeafToLeafAfter(regionEndr)(xs,root)(_,(focusedToLeaf,focused))=fromLeafAfterToFinalp0np0=regionStartrpruned=pruneNodesBeforep0focusedToLeaffocused-- | Return the first element that matches the predicate, or the last of the list-- if none matches.firstThat::(a->Bool)->[a]->afirstThat_[]=error"firstThat: empty list"firstThat_[x]=xfirstThatp(x:xs)=ifpxthenxelsefirstThatpxs-- | Return the element before first element that violates the predicate, or the first of the list-- if that one violates the predicate.lastThat::(a->Bool)->[a]->alastThat_[]=error"lastThat: empty list"lastThatp(x:xs)=ifpxthenworkxxselsexwhereworkx0[]=x0workx0(y:ys)=ifpythenworkyyselsex0-- | Given a path to a node, return a path+node which -- node that encompasses the given node + a point before it.fromLeafAfterToFinal::IsTreetree=>Point->Node(tree(Toka))->(Path,Node(tree(Toka)))fromLeafAfterToFinalpn=-- trace ("reg = " ++ show (fmap (subtreeRegion . snd) nsPth)) $ firstThat(\(_,(_,s))->getFirstOffsets<=p)nswherens=(reverse(nodesOnPathn))-- | Search the tree in pre-order starting at a given node, until finding a leaf which is at-- or after the given point. An effort is also made to return a leaf as close as possible to @p@.-- TODO: rename to fromLeafToLeafAtfromLeafToLeafAfter::IsTreetree=>Point->Node(tree(Toka))->Node(tree(Toka))fromLeafToLeafAfterp(xs,root)=trace"fromLeafToLeafAfter:"$trace("xs = "++showxs)$trace("xsValid = "++showxsValid)$trace("p = "++showp)$trace("leafBeforeP = "++showleafBeforeP)$trace("leaf ~ "++show(subtreeRegionleaf))$trace("xs' = "++showxs')$resultwherexs'=ifnullcandidateLeavesthen[]elsefst$firstOrLastThat(\(_,s)->getFirstOffsets>=p)candidateLeavescandidateLeaves=allLeavesRelativerelChildn(firstOrLastThat,relChild)=ifleafBeforePthen(firstThat,afterChild)else(lastThat,beforeChild)(xsValid,leaf)=wkDown(xs,root)leafBeforeP=getFirstOffsetleaf<=pn=(xsValid,root)result=(xs',root)allLeavesRelative::IsTreetree=>(Int->[(Int,treea)]->[(Int,treea)])->Node(treea)->[Node(treea)]allLeavesRelativeselect=filter(not.nullSubtree.snd).allLeavesRelative'select.reverse.nodesAndChildIndex-- we remove empty subtrees because their region is [0,0].-- | Takes a list of (node, index of already inspected child), and return all leaves-- in this node after the said child).allLeavesRelative'::IsTreetree=>(Int->[(Int,treea)]->[(Int,treea)])->[(Node(treea),Int)]->[Node(treea)]allLeavesRelative'selectl=[(xs++xs',t')|((xs,t),c)<-l,(xs',t')<-allLeavesRelativeChildselectct]-- | Given a root, return all the nodes encountered along it, their-- paths, and the index of the child which comes next.nodesAndChildIndex::IsTreetree=>Node(treea)->[(Node(treea),Int)]nodesAndChildIndex([],t)=[(([],t),negate1)]nodesAndChildIndex(x:xs,t)=caseindexx(subtreest)ofJustc'->(([],t),x):fmap(first$first(x:))(nodesAndChildIndex(xs,c'))Nothing->[(([],t),negate1)]nodesOnPath::IsTreetree=>Node(treea)->[(Path,Node(treea))]nodesOnPath([],t)=[([],([],t))]nodesOnPath(x:xs,t)=([],(x:xs,t)):caseindexx(subtreest)ofNothing->error"nodesOnPath: non-existent path"Justc->fmap(first(x:))(nodesOnPath(xs,c))beforeChild,afterChild::Int->[a]->[a]beforeChild(-1)=reverse-- (-1) indicates that all children should be taken.beforeChildc=reverse.take(c-1)afterChildc=drop(c+1)-- Return all leaves after or before child depending on the relation which is given.allLeavesRelativeChild::IsTreetree=>(Int->[(Int,treea)]->[(Int,treea)])->Int->treea->[Node(treea)]allLeavesRelativeChildselectct|nullts=[([],t)]|otherwise=[(x:xs,t')|(x,ct)<-selectc(zip[0..]ts),(xs,t')<-allLeavesInselectct]wherets=subtreest-- | Return all leaves (with paths) inside a given root.allLeavesIn::(IsTreetree)=>(Int->[(Int,treea)]->[(Int,treea)])->treea->[Node(treea)]allLeavesInselect=allLeavesRelativeChildselect(-1)-- | Return all subtrees in a tree; each element of the return list-- contains paths to nodes. (Root is at the start of each path)getAllPaths::IsTreetree=>treet->[[treet]]getAllPathst=fmap(++[t])([]:concatMapgetAllPaths(subtreest))goDown::IsTreetree=>Int->treet->Maybe(treet)goDowni=indexi.subtreesindex::Int->[a]->Maybeaindex_[]=Nothingindex0(h:_)=Justhindexn(_:t)=index(n-1)twalkDown::IsTreetree=>Node(treet)->Maybe(treet)walkDown([],t)=returntwalkDown(x:xs,t)=goDownxt>>=currywalkDownxswkDown::IsTreetree=>Node(treea)->Node(treea)wkDown([],t)=([],t)wkDown(x:xs,t)=casegoDownxtofNothing->([],t)Justt'->first(x:)$wkDown(xs,t')-- | Search the given list, and return the last tree before the given-- point; with path to the root. (Root is at the start of the path)getLastPath::IsTreetree=>[tree(Tokt)]->Point->Maybe[tree(Tokt)]getLastPathrootsoffset=casetakeWhile((<offset).posnOfs.snd)allSubPathPosnof[]->Nothingxs->Just$fst$lastxswhereallSubPathPosn=[(p,posn)|root<-roots,p@(t':_)<-getAllPathsroot,Justtok<-[getFirstElementt'],letposn=tokPosntok]-- | Return all subtrees in a tree, in preorder.getAllSubTrees::IsTreetree=>treet->[treet]getAllSubTreest=t:concatMapgetAllSubTrees(subtreest)-- | Return the 1st token of a subtree.getFirstElement::Foldablet=>ta->MaybeagetFirstElementtree=getFirst$foldMap(First.Just)treenullSubtree::Foldablet=>ta->BoolnullSubtree=null.toListgetFirstTok,getLastTok::Foldablet=>ta->MaybeagetFirstTok=getFirstElementgetLastTok=getLastElement-- | Return the last token of a subtree.getLastElement::Foldablet=>ta->MaybeagetLastElementtree=getLast$foldMap(Last.Just)treegetFirstOffset,getLastOffset::Foldablet=>t(Tokt1)->PointgetFirstOffset=maybe0tokBegin.getFirstTokgetLastOffset=maybe0tokEnd.getLastToksubtreeRegion::Foldablet=>t(Tokt1)->RegionsubtreeRegiont=mkRegion(getFirstOffsett)(getLastOffsett)-- | Given a tree, return (first offset, number of lines).getSubtreeSpan::(Foldabletree)=>tree(Tokt)->(Point,Int)getSubtreeSpantree=(posnOfs$first,lastLine-firstLine)wherebounds@[first,_last]=fmap(tokPosn.assertJust)[getFirstElementtree,getLastElementtree][firstLine,lastLine]=fmapposnLineboundsassertJust(Justx)=xassertJust_=error"assertJust: Just expected"--------------------------------------- Should be in Control.Applicative.?sepBy::(Alternativef)=>fa->fv->f[a]sepByps=sepBy1ps<|>pure[]sepBy1::(Alternativef)=>fa->fv->f[a]sepBy1ps=(:)<$>p<*>many(s*>p)------------------------------------------------------ Testing code.#ifdef TESTINGnodeRegion::IsTreetree=>Node(tree(Toka))->RegionnodeRegionn=subtreeRegiontwhereJustt=walkDownndataTesta=Empty|Leafa|Bin(Testa)(Testa)deriving(Show,Eq)instanceFoldableTestwherefoldMapf(Leafx)=fxfoldMapf(Bin_r)=foldMapfr<>foldMapfrinstanceIsTreeTestwhereuniplate(Binlr)=([l,r],\[l',r']->Binl'r')uniplatet=([],\[]->t)emptyNode=EmptytypeTT=Tok()instanceArbitrary(TestTT)wherearbitrary=sized$\size->doarbitraryFromList[1..size+1]shrink(Leaf_)=[]shrink(Binlr)=[l,r]++(Bin<$>shrinkl<*>purer)++(Bin<$>purel<*>shrinkr)tAt::Point->TTtAtidx=Tok()1(Posn(idx*2)00)arbitraryFromList::[Int]->Gen(TestTT)arbitraryFromList[]=error"arbitraryFromList expects non empty lists"arbitraryFromList[x]=pure(Leaf(tAt(fromIntegralx)))arbitraryFromListxs=dom<-choose(1,lengthxs-1)let(l,r)=splitAtmxsBin<$>arbitraryFromListl<*>arbitraryFromListrinstanceEq(Toka)wherex==y=tokPosnx==tokPosnyinstanceArbitraryRegionwherearbitrary=sized$\size->dox0::Int<-arbitraryreturn$mkRegion(fromIntegralx0)(fromIntegral(x0+size))newtypeNTTT=N(Node(TestTT))derivingShowinstanceArbitraryNTTTwherearbitrary=dot<-arbitraryp<-arbitraryPathtreturn$N(p,t)arbitraryPath::Testt->GenPatharbitraryPath(Leaf_)=return[]arbitraryPath(Binlr)=doc<-choose(0,1)letJustn'=indexc[l,r](c:)<$>arbitraryPathn'regionInside::Region->GenRegionregionInsider=dob::Int<-choose(fromIntegral$regionStartr,fromIntegral$regionEndr)e::Int<-choose(b,fromIntegral$regionEndr)return$mkRegion(fromIntegralb)(fromIntegrale)pointInside::Region->GenPointpointInsider=dop::Int<-choose(fromIntegral$regionStartr,fromIntegral$regionEndr)return(fromIntegralp)prop_fromLeafAfterToFinal::NTTT->Propertyprop_fromLeafAfterToFinal(Nn)=letfullRegion=subtreeRegion$sndninforAll(pointInsidefullRegion)$\p->doletfinal@(finalPath,(pathFromSubtree,finalSubtree))=fromLeafAfterToFinalpnfinalRegion=subtreeRegionfinalSubtreeinitialRegion=nodeRegionnwhenFail(doputStrLn$"final = "++showfinalputStrLn$"final reg = "++showfinalRegionputStrLn$"initialReg = "++showinitialRegionputStrLn$"p = "++showp)((regionStartfinalRegion<=p)&&(initialRegion`includedRegion`finalRegion))prop_allLeavesAfter::NTTT->Propertyprop_allLeavesAfter(Nn@(xs,t))=doletafter=allLeavesRelativeafterChildn(xs',t')<-elementsafterlett''=walkDown(xs',t)whenFail(doputStrLn$"t' = "++showt'putStrLn$"t'' = "++showt''putStrLn$"xs' = "++showxs')(Justt'==t''&&xs<=xs')prop_allLeavesBefore::NTTT->Propertyprop_allLeavesBefore(Nn@(xs,t))=doletafter=allLeavesRelativebeforeChildn(xs',t')<-elementsafterlett''=walkDown(xs',t)whenFail(doputStrLn$"t' = "++showt'putStrLn$"t'' = "++showt''putStrLn$"xs' = "++showxs')(Justt'==t''&&xs'<=xs)prop_fromNodeToLeafAfter::NTTT->Propertyprop_fromNodeToLeafAfter(Nn)=forAll(pointInside(subtreeRegion$sndn))$\p->doletafter=fromLeafToLeafAfterpnafterRegion=nodeRegionafterwhenFail(doputStrLn$"after = "++showafterputStrLn$"after reg = "++showafterRegion)(regionStartafterRegion>=p)prop_fromNodeToFinal::NTTT->Propertyprop_fromNodeToFinal(Nt)=forAll(regionInside(subtreeRegion$sndt))$\r->doletfinal@(finalPath,finalSubtree)=fromNodeToFinalrtfinalRegion=subtreeRegionfinalSubtreewhenFail(doputStrLn$"final = "++showfinalputStrLn$"final reg = "++showfinalRegionputStrLn$"leaf after = "++show(fromLeafToLeafAfter(regionEndr)t))$dor`includedRegion`finalRegion#endif