dual-tree-0.2.2.1/0000755000000000000000000000000007346545000011725 5ustar0000000000000000dual-tree-0.2.2.1/CHANGES0000755000000000000000000000256207346545000012730 0ustar0000000000000000* 0.2.2.1: 19 October 2019 - Allow semigroups-0.19 - Allow base-4.13 and test with GHC 8.8 * 0.2.2: 16 May 2018 - allow monoid-extras-0.5 - switch from deprecated Control.Newtype to C.N.Generics * 0.2.1.1: 5 April 2018 - allow base-4.11 for GHC-8.4 * 0.2.1: 3 July 2017 - migrate from newtype to newtype-generics dependency This change only affects internals of the library. - improve tests - allow base-4.10 - derive Typeable instead of deprecated Typeable1 - drop support for GHC < 7.8 * 0.2.0.9: 14 February 2016 - allow base-4.9 for GHC-8.0 * 0.2.0.8: 10 November 2015 - allow semigroups-0.18 * 0.2.0.7: 16 September 2015 - Allow semigroups-0.17 * 0.2.0.6: 3 April 2015 - Allow base-4.8 - Allow monoid-extras-0.4 * 0.2.0.5: 04 Dec 2014 - Allow semigroups-0.16 * 0.2.0.4: 28 May 2014 - Allow semigroups-0.15 * 0.2.0.3: 15 May 2014 - Allow semigroups-0.14 * 0.2.0.2: 10 April 2014 - Allow semigroups-0.13 * 0.2.0.1: 27 November 2013 - Allow semigroups-0.12 * 0.2: 5 November 2013 - Expose internal d-annotations via foldDUAL * 0.1.0.4: 26 September 2013 - allow semigroups-0.11 * 0.1.0.3: 15 July 2013 - bump monoid-extras upper bound to allow 0.3 * 0.1.0.2: 28 March 2013 - bump upper bound to allow base-4.7 * 0.1.0.1: 7 January 2013 - bump upper bound to allow semigroups-0.9 * 0.1.0.0: 3 September 2012 Initial release dual-tree-0.2.2.1/LICENSE0000644000000000000000000000330607346545000012734 0ustar0000000000000000Copyright (c) 2011-2016, dual-tree team: Daniel Bergey Christopher Chalmers Jeffrey Rosenbluth Ryan Yates Brent Yorgey All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Brent Yorgey nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. dual-tree-0.2.2.1/Setup.hs0000644000000000000000000000005607346545000013362 0ustar0000000000000000import Distribution.Simple main = defaultMain dual-tree-0.2.2.1/dual-tree.cabal0000644000000000000000000000541607346545000014601 0ustar0000000000000000name: dual-tree version: 0.2.2.1 synopsis: Rose trees with cached and accumulating monoidal annotations description: Rose (n-ary) trees with both upwards- (/i.e./ cached) and downwards-traveling (/i.e./ accumulating) monoidal annotations. This is used as the core data structure underlying the @diagrams@ framework (), but potentially has other applications as well. . 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 "Data.Tree.DUAL" for full documentation. "Data.Tree.DUAL" provides a public API which should suffice for most purposes. "Data.Tree.DUAL.Internal" exports more of the internal implementation---use it at your own risk. license: BSD3 license-file: LICENSE extra-source-files: CHANGES author: Brent Yorgey maintainer: diagrams-discuss@googlegroups.com category: Data build-type: Simple cabal-version: >=1.10 bug-reports: https://github.com/diagrams/dual-tree/issues tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2, GHC == 8.6.1, GHC == 8.8.1 source-repository head type: git location: https://github.com/diagrams/dual-tree.git library default-language: Haskell2010 exposed-modules: Data.Tree.DUAL Data.Tree.DUAL.Internal build-depends: base >= 4.3 && < 4.14, semigroups >= 0.8 && < 0.20, newtype-generics >= 0.5.3 && < 0.6, monoid-extras >= 0.2 && < 0.6 hs-source-dirs: src other-extensions: GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, TypeOperators, FlexibleContexts, DeriveDataTypeable test-suite test default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Test.hs hs-source-dirs: test build-depends: base, QuickCheck, testing-feat, monoid-extras, semigroups, dual-tree dual-tree-0.2.2.1/src/Data/Tree/0000755000000000000000000000000007346545000014264 5ustar0000000000000000dual-tree-0.2.2.1/src/Data/Tree/DUAL.hs0000644000000000000000000000712607346545000015353 0ustar0000000000000000 ----------------------------------------------------------------------------- -- | -- Module : Data.Tree.DUAL -- Copyright : (c) 2011-2012 Brent Yorgey -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Rose (n-ary) trees with both upwards- (/i.e./ cached) and -- downwards-traveling (/i.e./ accumulating) monoidal annotations. -- This is used as the core data structure underlying the @diagrams@ -- framework (), but potentially -- has other applications as well. -- -- 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\". -- -- Specifically, there are five types of nodes: -- -- * Leaf nodes which contain a data value of type @l@ and an -- annotation of type @u@. The annotation represents information -- about a tree that should be accumulated (/e.g./ number of -- leaves, some sort of \"weight\", /etc./). If you are familiar -- with finger trees -- (, -- ), it is the -- same idea. -- -- * There is also a special type of leaf node which contains only a -- @u@ value, and no data. This allows cached @u@ values to be -- \"modified\" by inserting extra annotations. -- -- * Branch nodes, containing a list of subtrees. -- -- * Internal nodes with a value of type @d@. @d@ may have an -- /action/ on @u@ (see the 'Action' type class, defined in -- "Data.Monoid.Action" from the @monoid-extras@ package). -- Semantically speaking, applying a @d@ annotation to a tree -- transforms all the @u@ annotations below it by acting on them. -- Operationally, however, since the action must be a monoid -- homomorphism, applying a @d@ annotation can actually be done in -- constant time. -- -- * Internal nodes with data values of type @a@, possibly of a -- different type than those in the leaves. These are just \"along -- for the ride\" and are unaffected by @u@ and @d@ annotations. -- -- There are two critical points to note about @u@ and @d@ annotations: -- -- * The combined @u@ annotation for an entire tree is always cached -- at the root and available in constant (amortized) time. -- -- * The 'mconcat' of all the @d@ annotations along the path from -- the root to each leaf is available along with the leaf during a -- fold operation. -- -- A fold over a @DUALTree@ is given access to the internal and leaf -- data, 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. It is also not given access to @d@ values as -- they occur in the tree, only as they accumulate at leaves. If you -- do need access to @u@ or @d@ values, you can duplicate the values -- you need in the internal data nodes. -- ----------------------------------------------------------------------------- module Data.Tree.DUAL ( -- * DUAL-trees DUALTree -- * Constructing DUAL-trees , empty, leaf, leafU, annot, applyD -- * Modifying DUAL-trees , applyUpre, applyUpost , mapU -- * Accessors and eliminators , getU, foldDUAL, flatten ) where import Data.Tree.DUAL.Internal dual-tree-0.2.2.1/src/Data/Tree/DUAL/0000755000000000000000000000000007346545000015011 5ustar0000000000000000dual-tree-0.2.2.1/src/Data/Tree/DUAL/Internal.hs0000644000000000000000000003264507346545000017133 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- 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. -- ----------------------------------------------------------------------------- module Data.Tree.DUAL.Internal ( -- * DUAL-trees DUALTreeNE(..), 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 ) where import Control.Arrow ((***)) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NEL import Data.Maybe (fromMaybe) import Data.Monoid.Action import Data.Semigroup import Data.Typeable import Control.Newtype.Generics ------------------------------------------------------------ -- DUALTreeNE ------------------------------------------------------------ -- | /Non-empty/ DUAL-trees. data DUALTreeNE d u a l = Leaf u l -- ^ Leaf with data value and @u@ annotation | LeafU u -- ^ Leaf with only @u@ annotation | Concat (NonEmpty (DUALTreeU d u a l)) -- ^ n-way branch, containing a /non-empty/ list -- of subtrees. | Act d (DUALTreeU d u a l) -- ^ @d@ annotation | Annot a (DUALTreeU d u a l) -- ^ Internal data value deriving (Functor, Typeable, Show, Eq) instance (Action d u, Semigroup u) => Semigroup (DUALTreeNE d u a l) where t1 <> t2 = sconcat (NEL.fromList [t1,t2]) sconcat = Concat . NEL.map pullU newtype DAct d = DAct { unDAct :: d } instance Newtype (DAct d) where type O (DAct d) = d pack = DAct unpack = unDAct instance (Semigroup d, Semigroup u, Action d u) => Action (DAct d) (DUALTreeNE d u a l) where act (DAct d) (Act d' t) = Act (d <> d') t act (DAct d) t = Act d (pullU t) ------------------------------------------------------------ -- DUALTreeU ------------------------------------------------------------ -- | A non-empty DUAL-tree paired with a cached @u@ value. These -- should never be constructed directly; instead, use 'pullU'. newtype DUALTreeU d u a l = DUALTreeU { unDUALTreeU :: (u, DUALTreeNE d u a l) } deriving (Functor, Semigroup, Typeable, Show, Eq) instance Newtype (DUALTreeU d u a l) where type O (DUALTreeU d u a l) = (u, DUALTreeNE d u a l) pack = DUALTreeU unpack = unDUALTreeU instance (Semigroup d, Semigroup u, Action d u) => Action (DAct d) (DUALTreeU d u a l) where act d = over DUALTreeU (act (unDAct d) *** act d) -- | \"Pull\" the root @u@ annotation out into a tuple. pullU :: (Semigroup u, Action d u) => DUALTreeNE d u a l -> DUALTreeU d u a l pullU t@(Leaf u _) = pack (u, t) pullU t@(LeafU u) = pack (u, t) pullU t@(Concat ts) = pack (sconcat . NEL.map (fst . unpack) $ ts, t) pullU t@(Act d (DUALTreeU (u,_))) = pack (act d u, t) pullU t@(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. newtype DUALTree d u a l = DUALTree { unDUALTree :: Option (DUALTreeU d u a l) } deriving ( Functor, Semigroup, Typeable, Show, Eq ) instance Newtype (DUALTree d u a l) where type O (DUALTree d u a l) = Option (DUALTreeU d u a l) pack = DUALTree unpack = unDUALTree instance (Semigroup u, Action d u) => Monoid (DUALTree d u a l) where mempty = DUALTree mempty mappend = (<>) mconcat [] = mempty mconcat (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 (Semigroup d, Semigroup u, Action d u) => Action (DAct d) (DUALTree d u a l) where act = over DUALTree . fmap . act ------------------------------------------------------------ -- Convenience methods etc. ------------------------------------------------------------ -- | The empty DUAL-tree. This is a synonym for 'mempty', but with a -- more general type. empty :: DUALTree d u a l empty = DUALTree (Option Nothing) -- | Construct a leaf node from a @u@ annotation along with a leaf -- datum. leaf :: u -> l -> DUALTree d u a l leaf u l = DUALTree (Option (Just (DUALTreeU (u, Leaf u l)))) -- | Construct a leaf node from a @u@ annotation. leafU :: u -> DUALTree d u a l leafU u = DUALTree (Option (Just (DUALTreeU (u, LeafU u)))) -- | 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 :: (Semigroup u, Action d u) => u -> DUALTree d u a l -> DUALTree d u a l applyUpre u t = leafU u <> 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 :: (Semigroup u, Action d u) => u -> DUALTree d u a l -> DUALTree d u a l applyUpost u t = t <> leafU u -- | 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 :: (Semigroup u, Action d u) => a -> DUALTree d u a l -> DUALTree d u a l annot a = (over DUALTree . fmap) (pullU . Annot a) -- | Apply a @d@ annotation at the root of a tree, transforming all -- @u@ annotations by the action of @d@. applyD :: (Semigroup d, Semigroup u, Action d u) => d -> DUALTree d u a l -> DUALTree d u a l applyD = 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 :: DUALTree d u a l -> Maybe (u, DUALTreeNE d u a l) nonEmpty = fmap unpack . getOption . unpack -- | Get the @u@ annotation at the root, or @Nothing@ if the tree is -- empty. getU :: DUALTree d u a l -> Maybe u getU = fmap fst . 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') -> DUALTreeNE d u a l -> DUALTreeNE d u' a l mapUNE f (Leaf u l) = Leaf (f u) l mapUNE f (LeafU u) = LeafU (f u) mapUNE f (Concat ts) = Concat ((NEL.map . mapUU) f ts) mapUNE f (Act d t) = Act d (mapUU f t) mapUNE f (Annot a t) = Annot a (mapUU f t) -- | 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') -> DUALTreeU d u a l -> DUALTreeU d u' a l mapUU f = over DUALTreeU (f *** mapUNE f) -- | 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') -> DUALTree d u a l -> DUALTree d u' a l mapU = over DUALTree . fmap . mapUU ------------------------------------------------------------ -- Folds ------------------------------------------------------------ -- | Fold for non-empty DUAL-trees. foldDUALNE :: (Semigroup d, Monoid d) => (d -> l -> r) -- ^ Process a leaf datum along with the -- accumulation of @d@ values along the -- path from the root -> r -- ^ Replace @LeafU@ nodes -> (NonEmpty r -> r) -- ^ Combine results at a branch node -> (d -> r -> r) -- ^ Process an internal d node -> (a -> r -> r) -- ^ Process an internal datum -> DUALTreeNE d u a l -> r foldDUALNE = foldDUALNE' (Option Nothing) where foldDUALNE' dacc lf _ _ _ _ (Leaf _ l) = lf (option mempty id dacc) l foldDUALNE' _ _ lfU _ _ _ (LeafU _) = lfU foldDUALNE' dacc lf lfU con down ann (Concat ts) = con (NEL.map (foldDUALNE' dacc lf lfU con down ann . snd . unpack) ts) foldDUALNE' dacc lf lfU con down ann (Act d t) = down d (foldDUALNE' (dacc <> (Option (Just d))) lf lfU con down ann . snd . unpack $ t) foldDUALNE' dacc lf lfU con down ann (Annot a t) = ann a (foldDUALNE' dacc lf lfU con down ann . 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 :: (Semigroup d, Monoid d) => (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 -> (NonEmpty r -> r) -- ^ Combine results at a branch node -> (d -> r -> r) -- ^ Process an internal d node -> (a -> r -> r) -- ^ Process an internal datum -> DUALTree d u a l -> Maybe r foldDUAL _ _ _ _ _ (DUALTree (Option Nothing)) = Nothing foldDUAL l u c d a (DUALTree (Option (Just (DUALTreeU (_, t))))) = Just $ foldDUALNE l u c d a t -- | A specialized fold provided for convenience: flatten a tree into -- a list of leaves along with their @d@ annotations, ignoring -- internal data values. flatten :: (Semigroup d, Monoid d) => DUALTree d u a l -> [(l, d)] flatten = fromMaybe [] . foldDUAL (\d l -> [(l, d)]) [] (concat . NEL.toList) (flip const) (const id) dual-tree-0.2.2.1/test/0000755000000000000000000000000007346545000012704 5ustar0000000000000000dual-tree-0.2.2.1/test/Test.hs0000644000000000000000000000621107346545000014157 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} import Data.Functor import Data.Maybe import Data.Typeable import Test.QuickCheck.All (quickCheckAll) import Test.QuickCheck hiding ((===)) import Test.Feat import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NEL import Data.Monoid.Action import Data.Semigroup import Data.Tree.DUAL data DUALTreeExpr d u a l = EEmpty | ELeaf u l | ELeafU u | EConcat (NonEmpty (DUALTreeExpr d u a l)) | EAct d (DUALTreeExpr d u a l) | EAnnot a (DUALTreeExpr d u a l) deriving (Show, Typeable) deriveEnumerable ''NonEmpty deriveEnumerable ''DUALTreeExpr buildTree :: (Semigroup u, Semigroup d, Action d u) => DUALTreeExpr d u a l -> DUALTree d u a l buildTree EEmpty = empty buildTree (ELeaf u l) = leaf u l buildTree (ELeafU u) = leafU u buildTree (EConcat ts) = sconcat (NEL.map buildTree ts) buildTree (EAct d t) = applyD d (buildTree t) buildTree (EAnnot a t) = annot a (buildTree t) -- buildTree' :: DUALTreeExpr D U () Bool -> DUALTree D U () Bool -- buildTree' = buildTree instance Num a => Action (Product a) (Sum a) where act (Product p) (Sum s) = Sum (p * s) type U = Sum Int type D = Product Int deriving instance Typeable Sum deriving instance Typeable Product deriveEnumerable ''Sum deriveEnumerable ''Product type T = DUALTree D U Bool Bool instance Arbitrary T where arbitrary = buildTree <$> sized uniform prop_leaf_u :: U -> Bool prop_leaf_u u = getU (leaf u ()) == Just u prop_leafU_u :: U -> Bool prop_leafU_u u = getU (leafU u) == Just u prop_applyUpre :: U -> T -> Bool prop_applyUpre u t = getU (applyUpre u t) == Just (u <> fromMaybe mempty (getU t)) prop_applyUpost :: U -> T -> Bool prop_applyUpost u t = getU (applyUpost u t) == Just (fromMaybe mempty (getU t) <> u) -------------------------------------------------- -- Monoid laws -------------------------------------------------- prop_mempty_idL :: T -> Bool prop_mempty_idL t = mempty <> t == t prop_mempty_idR :: T -> Bool prop_mempty_idR t = t <> mempty == t infix 4 === t1 === t2 = flatten t1 == flatten t2 -- mappend is associative up to flattening. prop_mappend_assoc :: T -> T -> T -> Bool prop_mappend_assoc t1 t2 t3 = (t1 <> t2) <> t3 === t1 <> (t2 <> t3) -------------------------------------------------- -- Action laws -------------------------------------------------- prop_mempty_act :: T -> Bool prop_mempty_act t = applyD mempty t === t prop_mappend_act :: D -> D -> T -> Bool prop_mappend_act d1 d2 t = applyD d1 (applyD d2 t) == applyD (d1 <> d2) t prop_act_mempty :: D -> Bool prop_act_mempty d = applyD d (mempty :: T) == mempty prop_act_mappend :: D -> T -> T -> Bool prop_act_mappend d t1 t2 = applyD d (t1 <> t2) === applyD d t1 <> applyD d t2 return [] main = $quickCheckAll