{-# LANGUAGE DeriveDataTypeable #-}{-# LANGUAGE DeriveFunctor #-}{-# LANGUAGE FlexibleContexts #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE GeneralizedNewtypeDeriving #-}{-# LANGUAGE MultiParamTypeClasses #-}{-# LANGUAGE TypeOperators #-}------------------------------------------------------------------------------- |-- Module : Data.Tree.DUAL.Internal-- Copyright : (c) 2011-2012 Brent Yorgey-- License : BSD-style (see LICENSE)-- Maintainer : diagrams-discuss@googlegroups.com---- This module provides access to all of the internals of the-- DUAL-tree implementation. Depend on the internals at your own-- risk! For a safe public API (and complete documentation), see-- "Data.Tree.DUAL".---- The main things exported by this module which are not exported from-- "Data.Tree.DUAL" are two extra types used in the implementation of-- 'DUALTree', along with functions for manipulating them. A type of-- /non-empty/ trees, 'DUALTreeNE', is defined, as well as the type-- 'DUALTreeU' which represents a non-empty tree paired with a cached-- @u@ annotation. 'DUALTreeNE' and 'DUALTreeU' are mutually-- recursive, so that recursive tree nodes are interleaved with cached-- @u@ annotations. 'DUALTree' is defined by just wrapping-- 'DUALTreeU' in 'Option'. This method has the advantage that the-- type system enforces the invariant that there is only one-- representation for the empty tree. It also allows us to get away-- with only 'Semigroup' constraints in many places.-------------------------------------------------------------------------------moduleData.Tree.DUAL.Internal(-- * DUAL-treesDUALTreeNE(..),DUALTreeU(..),DUALTree(..)-- * Constructing DUAL-trees,empty,leaf,leafU,annot,applyD-- * Modifying DUAL-trees,applyUpre,applyUpost,mapUNE,mapUU,mapU-- * Accessors and eliminators,nonEmpty,getU,foldDUALNE,foldDUAL,flatten)whereimportControl.Arrow((***))importData.List.NonEmpty(NonEmpty(..))importqualifiedData.List.NonEmptyasNELimportData.Maybe(fromMaybe)importData.Monoid.ActionimportData.SemigroupimportData.TypeableimportControl.Newtype-------------------------------------------------------------- DUALTreeNE-------------------------------------------------------------- | /Non-empty/ DUAL-trees.dataDUALTreeNEdual=Leaful-- ^ Leaf with data value and @u@ annotation|LeafUu-- ^ Leaf with only @u@ annotation|Concat(NonEmpty(DUALTreeUdual))-- ^ n-way branch, containing a /non-empty/ list-- of subtrees.|Actd(DUALTreeUdual)-- ^ @d@ annotation|Annota(DUALTreeUdual)-- ^ Internal data valuederiving(Functor,Typeable,Show,Eq)instance(Actiondu,Semigroupu)=>Semigroup(DUALTreeNEdual)wheret1<>t2=sconcat(NEL.fromList[t1,t2])sconcat=Concat.NEL.mappullUnewtypeDActd=DAct{unDAct::d}instanceNewtype(DActd)dwherepack=DActunpack=unDActinstance(Semigroupd,Semigroupu,Actiondu)=>Action(DActd)(DUALTreeNEdual)whereact(DActd)(Actd't)=Act(d<>d')tact(DActd)t=Actd(pullUt)-------------------------------------------------------------- DUALTreeU-------------------------------------------------------------- | A non-empty DUAL-tree paired with a cached @u@ value. These-- should never be constructed directly; instead, use 'pullU'.newtypeDUALTreeUdual=DUALTreeU{unDUALTreeU::(u,DUALTreeNEdual)}deriving(Functor,Semigroup,Typeable,Show,Eq)instanceNewtype(DUALTreeUdual)(u,DUALTreeNEdual)wherepack=DUALTreeUunpack=unDUALTreeUinstance(Semigroupd,Semigroupu,Actiondu)=>Action(DActd)(DUALTreeUdual)whereactd=overDUALTreeU(act(unDActd)***actd)-- | \"Pull\" the root @u@ annotation out into a tuple.pullU::(Semigroupu,Actiondu)=>DUALTreeNEdual->DUALTreeUdualpullUt@(Leafu_)=pack(u,t)pullUt@(LeafUu)=pack(u,t)pullUt@(Concatts)=pack(sconcat.NEL.map(fst.unpack)$ts,t)pullUt@(Actd(DUALTreeU(u,_)))=pack(actdu,t)pullUt@(Annot_(DUALTreeU(u,_)))=pack(u,t)-------------------------------------------------------------- DUALTree-------------------------------------------------------------- | Rose (n-ary) trees with both upwards- (/i.e./ cached) and-- downwards-traveling (/i.e./ accumulating) monoidal annotations.-- Abstractly, a DUALTree is a rose (n-ary) tree with data (of type-- @l@) at leaves, data (of type @a@) at internal nodes, and two-- types of monoidal annotations, one (of type @u@) travelling-- \"up\" the tree and one (of type @d@) traveling \"down\". See-- the documentation at the top of this file for full details.---- @DUALTree@ comes with some instances:---- * 'Functor', for modifying leaf data. Note that 'fmap' of course-- cannot alter any @u@ annotations.---- * 'Semigroup'. @DUALTreeNE@s form a semigroup where @(\<\>)@-- corresponds to adjoining two trees under a common parent root,-- with @sconcat@ specialized to put all the trees under a single-- parent. Note that this does not satisfy associativity up to-- structural equality, but only up to observational equivalence-- under 'flatten'. Technically using 'foldDUAL' directly enables-- one to observe the difference, but it is understood that-- 'foldDUAL' should be used only in ways such that reassociation-- of subtrees \"does not matter\".---- * 'Monoid'. The identity is the empty tree.newtypeDUALTreedual=DUALTree{unDUALTree::Option(DUALTreeUdual)}deriving(Functor,Semigroup,Typeable,Show,Eq)instanceNewtype(DUALTreedual)(Option(DUALTreeUdual))wherepack=DUALTreeunpack=unDUALTreeinstance(Semigroupu,Actiondu)=>Monoid(DUALTreedual)wheremempty=DUALTreememptymappend=(<>)mconcat[]=memptymconcat(x:xs)=sconcat(x:|xs)-- | Apply a @d@ annotation at the root of a tree. Semantically, all-- @u@ annotations are transformed by the action of @d@, although-- operationally @act@ incurs only a constant amount of work.instance(Semigroupd,Semigroupu,Actiondu)=>Action(DActd)(DUALTreedual)whereact=overDUALTree.fmap.act-------------------------------------------------------------- Convenience methods etc.-------------------------------------------------------------- | The empty DUAL-tree. This is a synonym for 'mempty', but with a-- more general type.empty::DUALTreedualempty=DUALTree(OptionNothing)-- | Construct a leaf node from a @u@ annotation along with a leaf-- datum.leaf::u->l->DUALTreedualleaful=DUALTree(Option(Just(DUALTreeU(u,Leaful))))-- | Construct a leaf node from a @u@ annotation.leafU::u->DUALTreedualleafUu=DUALTree(Option(Just(DUALTreeU(u,LeafUu))))-- | Add a @u@ annotation to the root, combining it (on the left) with-- the existing cached @u@ annotation. This function is provided-- just for convenience; @applyUpre u t = 'leafU' u \<\> t@.applyUpre::(Semigroupu,Actiondu)=>u->DUALTreedual->DUALTreedualapplyUpreut=leafUu<>t-- | Add a @u@ annotation to the root, combining it (on the right) with-- the existing cached @u@ annotation. This function is provided-- just for convenience; @applyUpost u t = t \<\> 'leafU' u@.applyUpost::(Semigroupu,Actiondu)=>u->DUALTreedual->DUALTreedualapplyUpostut=t<>leafUu-- | Add an internal data value at the root of a tree. Note that this-- only works on /non-empty/ trees; on empty trees this function is-- the identity.annot::(Semigroupu,Actiondu)=>a->DUALTreedual->DUALTreedualannota=(overDUALTree.fmap)(pullU.Annota)-- | Apply a @d@ annotation at the root of a tree, transforming all-- @u@ annotations by the action of @d@.applyD::(Semigroupd,Semigroupu,Actiondu)=>d->DUALTreedual->DUALTreedualapplyD=act.DAct-- | Decompose a DUAL-tree into either @Nothing@ (if empty) or a-- top-level cached @u@ annotation paired with a non-empty-- DUAL-tree.nonEmpty::DUALTreedual->Maybe(u,DUALTreeNEdual)nonEmpty=fmapunpack.getOption.unpack-- | Get the @u@ annotation at the root, or @Nothing@ if the tree is-- empty.getU::DUALTreedual->MaybeugetU=fmapfst.nonEmpty-------------------------------------------------------------- Maps-------------------------------------------------------------- XXX todo: try adding Map as a constructor, so we can delay the-- mapping until the end too?-- | Map a function (which must be a monoid homomorphism, and commute-- with the action of @d@) over all the @u@ annotations in a non-empty-- DUAL-tree.mapUNE::(u->u')->DUALTreeNEdual->DUALTreeNEdu'almapUNEf(Leaful)=Leaf(fu)lmapUNEf(LeafUu)=LeafU(fu)mapUNEf(Concatts)=Concat((NEL.map.mapUU)fts)mapUNEf(Actdt)=Actd(mapUUft)mapUNEf(Annotat)=Annota(mapUUft)-- | Map a function (which must be a monoid homomorphism, and commute-- with the action of @d@) over all the @u@ annotations in a-- non-empty DUAL-tree paired with its cached @u@ value.mapUU::(u->u')->DUALTreeUdual->DUALTreeUdu'almapUUf=overDUALTreeU(f***mapUNEf)-- | Map a function over all the @u@ annotations in a DUAL-tree. The-- function must be a monoid homomorphism, and must commute with the-- action of @d@ on @u@. That is, to use @mapU f@ safely it must be-- the case that---- * @f mempty == mempty@---- * @f (u1 \<\> u2) == f u1 \<\> f u2@---- * @f (act d u) == act d (f u)@--mapU::(u->u')->DUALTreedual->DUALTreedu'almapU=overDUALTree.fmap.mapUU-------------------------------------------------------------- Folds-------------------------------------------------------------- | Fold for non-empty DUAL-trees.foldDUALNE::(Semigroupd,Monoidd)=>(d->l->r)-- ^ Process a leaf datum along with the-- accumulation of @d@ values along the-- path from the root->r-- ^ Replace @LeafU@ nodes->(NonEmptyr->r)-- ^ Combine results at a branch node->(d->r->r)-- ^ Process an internal d node->(a->r->r)-- ^ Process an internal datum->DUALTreeNEdual->rfoldDUALNE=foldDUALNE'(OptionNothing)wherefoldDUALNE'dacclf____(Leaf_l)=lf(optionmemptyiddacc)lfoldDUALNE'__lfU___(LeafU_)=lfUfoldDUALNE'dacclflfUcondownann(Concatts)=con(NEL.map(foldDUALNE'dacclflfUcondownann.snd.unpack)ts)foldDUALNE'dacclflfUcondownann(Actdt)=downd(foldDUALNE'(dacc<>(Option(Justd)))lflfUcondownann.snd.unpack$t)foldDUALNE'dacclflfUcondownann(Annotat)=anna(foldDUALNE'dacclflfUcondownann.snd.unpack$t)-- | Fold for DUAL-trees. It is given access to the internal and leaf-- data, internal @d@ values, and the accumulated @d@ values at each-- leaf. It is also allowed to replace \"@u@-only\" leaves with a-- constant value. In particular, however, it is /not/ given access-- to any of the @u@ annotations, the idea being that those are used-- only for /constructing/ trees. If you do need access to @u@-- values, you can duplicate the values you need in the internal-- data nodes.---- Be careful not to mix up the @d@ values at internal nodes with-- the @d@ values at leaves. Each @d@ value at a leaf satisfies the-- property that it is the 'mconcat' of all internal @d@ values-- along the path from the root to the leaf.---- The result is @Nothing@ if and only if the tree is empty.foldDUAL::(Semigroupd,Monoidd)=>(d->l->r)-- ^ Process a leaf datum along with the-- accumulation of @d@ values along the-- path from the root->r-- ^ Replace @u@-only nodes->(NonEmptyr->r)-- ^ Combine results at a branch node->(d->r->r)-- ^ Process an internal d node->(a->r->r)-- ^ Process an internal datum->DUALTreedual->MayberfoldDUAL_____(DUALTree(OptionNothing))=NothingfoldDUALlucda(DUALTree(Option(Just(DUALTreeU(_,t)))))=Just$foldDUALNElucdat-- | A specialized fold provided for convenience: flatten a tree into-- a list of leaves along with their @d@ annotations, ignoring-- internal data values.flatten::(Semigroupd,Monoidd)=>DUALTreedual->[(l,d)]flatten=fromMaybe[].foldDUAL(\dl->[(l,d)])[](concat.NEL.toList)(flipconst)(constid)