+
+GHC AST has some funny types which "blow up" if you examine them.
+SYB works by attempting unsafeCoerce's, which triggers these holes.
+We need a "staged" version of ghom (at least).
+The HaRe source contains a good model of this (its GhcUtils.hs module).
+Using that I made ghomStaged
+
+
+
+ ghomStaged :: forall r d. Data d =>
+ SYB.Stage
+ -> r
+ -> (r -> r -> r)
+ -> GenericQ r
+ -> d
+ -> Homo r
+ ghomStaged stage z k f x
+ | checkItemStage stage x = z'
+ | otherwise = foldl k' b (gmapQ (ghomStaged stage z k f) x)
+ where
+ b = R (f x) []
+ z' = R z []
+ k' (R r chs) nod@(R r' chs') = R (r `k` r') (chs++[nod])
+
+
+
+checkItemStage is from HaRe and can be found in the
+download.
+
+Note also you will need to have ghc-syb-utils installed for these experiments.
+
+
+Without worrying about its content, here is a small sample module we parse into an AST using the GHC API
+
+
+
+ -- an example from http://blog.ezyang.com/2011/05/anatomy-of-a-thunk-leak/
+ module A05 ( main ) where
+ import Control.Exception ( evaluate )
+ main = evaluate (f [1..4000000] (0 :: Int, 1 :: Int))
+ f [] c = c
+ f (x:xs) c = f xs (tick x c)
+ tick x (c0, c1) | even x = (c0, c1 + 1)
+ | otherwise = (c0 + 1, c1)
+
+
+
+This page shows the monstrous, usual output if we show the typechecked AST for the above small sample module.
+
+We can summarise its structure thus
+
+
+
+And this page shows the result of weightedShapeOfStaged applied to the staged GHC AST. These prove that our staged version works.
+
+
+Note that you do get a runtime error if you use weightedShapeOf (the unstaged version).
+You can see one such hole in the first line below
+
+
+ .
+ .
+ .
+ (WpHole) {!NameSet placeholder here!}
+ (Nothing)))]}))]}
+------------------------- weightedShapeOf typechecked
+test: panic! (the 'impossible' happened)
+ (GHC version 7.6.3 for i386-unknown-linux):
+ placeHolderNames
+
+Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug
+
+
+
+Finally, let's use filterHomo to do some pruning.
+We no longer need to worry about GHC staging holes, or generic programming -- we're in the homogeneous type of our choice now -- in this case, Homo Int.
+
+
+
+
+
+
diff --git a/HTML/ghc1.html b/HTML/ghc1.html
new file mode 100644
--- /dev/null
+++ b/HTML/ghc1.html
@@ -0,0 +1,475 @@
+
+
+
+
+Generic shapeOf etc. - GHC1
+
+
+
+
+
+Here's our sample Haskell module for playing with the GHC AST
+
+
+
+ -- an example from http://blog.ezyang.com/2011/05/anatomy-of-a-thunk-leak/
+ module A05 ( main ) where
+ import Control.Exception ( evaluate )
+ main = evaluate (f [1..4000000] (0 :: Int, 1 :: Int))
+ f [] c = c
+ f (x:xs) c = f xs (tick x c)
+ tick x (c0, c1) | even x = (c0, c1 + 1)
+ | otherwise = (c0 + 1, c1)
+
+
+
+
+This is the usual way to show the GHC AST
+
+
+
+
+
+
+
+
diff --git a/HTML/sai-shape-syb.html b/HTML/sai-shape-syb.html
new file mode 100644
--- /dev/null
+++ b/HTML/sai-shape-syb.html
@@ -0,0 +1,693 @@
+
+
+
+Generic shapeOf, and more General Homomorphisms
+
+
+
+
+
Download
+
+Here's full source (BSD3-licensed, Cabal sdist) for:
+
+
building the library (providing Data.Generics.Shape.{SYB, SYB.Filter, SYB.GHC}), and
+
building the testbench corresponding to the examples in this post.
+
+
+
Generic Shape
+
+It is sometimes useful to "project out" the shape or skeleton of a data structure.
+In abstract algebra, structure-preserving maps are called homomorphisms.
+Category theory is sometimes described of as the study of homomorphisms, which are there called morphisms.
+
+
+Although I like theory, I'm not a theoretician so this post may annoy those with high expectations in terms of knowledge of type theory, CT etc.
+However, I'm pleased with the results, and learned a fair bit, and it may help someone out of a practical bind down the road, so here it is.
+Motivated by a particular need, to work with some very complicated types (GHC AST) in a quick and dirty way.
+A couple days' work would have sufficed, but to bring the library up to a shareable quality took a few more.
+Not only did I get my GHC API hacks;
+by a slight generalisation of the original idea, it looks like it'll solve the most potentially work-intensive plumbing stage of a big project.
+Delightful!
+Whether it will be sufficiently performant remains to be seen...
+
+
+A couple days ago I started searching for information about how to implement such a generic homomorphism in Haskell, and even asked on the IRC, but didn't turn up anything despite some advice from experienced people.
+If I'd hit on the right keyword -- shape -- I'd have doubtlessly been directed to one of the excellent libraries in packages shapely-data and fixplate.
+
+
+I think either of these would probably have sufficed for the task, but I don't presently have an inclination to confirm this.
+These packages are not needed to build this library or test.
+At some point soon I'd like to make a careful study of shapely-data and perhaps fixplate.
+I feel humbled when I look at the beautiful API for shapely-data, even though I don't know how to use it or what its capabilities are yet.
+By comparison, my implementation is much less grounded in theory, and is probably weaker in every way.
+If nothing else, this mini-project has revitalised my interest in the theory side.
+
+
+This implementation:
+
+
provides a SYB alternative (shapely-data uses Template Haskell, and fixplate uses Uniplate)
+
provides "staged" variants of key functions, needed to work with the GHC API
+
my code is much smaller than either of those libraries, so that we can talk about all of it in one post.
+
+
+
Code and Examples
+
+
+Homomorphism can preserve some value information, in addition to the structure, mapping to a k-ary tree of homogeneous type, such as Rose a
+
+
+
+ data Rose a = R a [Rose a]
+
+
+
+with the constant-valued ("parentheses langauge") representation obtained for
+
+a ~ ().
+
+
+Achieving this for a homogeneous recursive source type is straightforward.
+However, we would like a generic solution, to handle arbitrary (heterogeneous) recursive types.
+
+
+In Haskell, this is possible using a generics library such as SYB or Uniplate.
+I chose SYB as I had a little past experience with that.
+If you want to run the code, you'll need to install the SYB package.
+
+
+This package supports a generic mapping which works over arbitrary recursive heterogeneous types.
+It differs from existing generic fmap (SYB's gmapT, or Oleg's gmap), in that it allows you to obtain a homogeneous result in the type of your choice, rather than adhering to the original types.
+Hence, this is not an fmap, it doesn't satisfy the laws.
+(It's a homomorphism.)
+It uses gfoldl, so fold-as-map.
+This theme is not new, but it's my take on a useful idea.
+I'm not trying to contribute theoretically, I just needed these tools and didn't find them. :)
+
+
+What I came up with is summarised in the following code
+
+
+ {-# LANGUAGE Rank2Types #-}
+
+ import Data.Data ( Data )
+ import Data.Data ( gmapQ )
+ import Data.Generics.Aliases ( GenericQ )
+
+ data Rose a = R a [Rose a] deriving Show
+ type Homo a = Rose a
+ type Shape = Homo ()
+
+ -- (Note: This is now ghomK in the API.)
+ ghom :: forall r d. Data d =>
+ (r -> r -> r)
+ -> GenericQ r
+ -> d
+ -> Homo r
+ ghom k f x = foldl k' b (gmapQ (ghom k f) x)
+ where
+ b = R (f x) []
+ k' (R r chs) nod@(R r' _) = R (r `k` r') (chs++[nod])
+
+
+
+(If you use (nod:chs) the structure will be flipped horizontally.)
+
+
+From this we can easily write the desired generic shapeOf
+
+
+
+ shapeOf :: forall d. Data d => d -> Shape
+ shapeOf = ghom (\_ _->()) (const ())
+
+
+
+Without more ado, it's also possible to write a function which maps arbitrary data to its weighted tree representation
+
+
+
+ weightedShapeOf :: forall d. Data d => d -> Homo Int
+ weightedShapeOf = ghom (+) (const 1)
+
+
+
+We can also use it to preserve choice values.
+
+Let's run some tests.
+
+[Apologies that the examples aren't very good, but they at least demonstrate usage.]
+
+
+
+
+
+I have also tested this on GHC parse trees (the motivating problem), and it works fine, but there is a catch.
+These results are reported here.
+
+
+So, for what it's worth, I was able to implement the generic homomorphisms.
+Probably this is already supported by some library, but I was unlucky in my search.
+
+
+Future work will include:
+
+
Implementing a true ghomP which prunes during generic traversal, using a fully generic stop condition (one pesky compiler error about a missing Typeable instance remains...). This would complement filterHomo, which acts post-mapping. The current ghomP' is a hack which gives you pruning, but only over the target values (i.e. post-mapped).
+
I forget the second one...
+
Would like to implement in Uniplate as well. Also in TH, if that's possible, just to get some experience with these.
+
+Generic shapeOf, and more General Homomorphisms - The Test
+
+
+
+
+
Test Code
+
+
+
+Needs fresh.
+
+
+
+
+
+
+
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2014, Andrew Seniuk
+
+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 Andrew Seniuk 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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/sai-shape-syb.cabal b/sai-shape-syb.cabal
new file mode 100644
--- /dev/null
+++ b/sai-shape-syb.cabal
@@ -0,0 +1,202 @@
+
+name: sai-shape-syb
+version: 0.2.0
+synopsis: Obtain homogeneous values from arbitrary values, tramsforming or culling data
+description:
+ This package provides SYB shape support: generic fmap to
+ homogeneous types, and related features. Complements existing
+ Uniplate and TH shape libraries. See
+ for more information.
+ .
+ Given a value of arbitrary complexity (mutually recursive
+ heterogeneous constructor application), you can obtain
+ a structure-preserving representation (homomorphism) as
+ a homogeneous type @Homo a@, parameterised by any choice type @a@.
+license: BSD3
+license-file: LICENSE
+author: Andrew Seniuk
+maintainer: rasfar@gmail.com
+homepage: http://www.fremissant.net/shape-syb
+-- URL with bug-tracker server preferred to email:
+bug-reports: rasfar@gmail.com
+category: Generics
+build-type: Simple
+-- extra-source-files:
+cabal-version: >=1.10
+stability: experimental
+
+extra-source-files: tests/*.hs
+ , HTML/*.html
+ , HTML/*.css
+
+-- source-repository head
+-- type: git
+-- location: https://github.com/rasfar/shape-syb
+
+Flag USE_DATA_TREE
+ Description: Use Data.Tree instead of custom Rose type
+ Default: True
+--Default: False
+
+-- Flag OPTIMISE
+-- Description: Use -O2 (etc.); otherwise, use -O0
+-- --Default: True
+-- Default: False
+--
+-- Flag PROFILE
+-- Description: Enable profiling
+-- --Default: True
+-- Default: False
+--
+-- Flag DYNAMIC
+-- Description: Enable dynamically-linked executable
+-- --Default: True
+-- Default: False
+
+Library
+ exposed-modules: SAI.Data.Generics.Shape
+ , SAI.Data.Generics.Shape.SYB
+ , SAI.Data.Generics.Shape.SYB.Filter
+ , SAI.Data.Generics.Shape.SYB.GHC
+ -- other-modules:
+ -- other-extensions:
+ build-depends:
+ base >= 4.0 && < 5.0
+-- XXX VERY BAD!!! (overconstrained)
+-- base ==4.6.*
+ -- b/c Glide cannot resolve deps with 0.4.2
+-- , syb ==0.4.1
+ , syb
+ -- version is "phoney" (patch of mine, add-source'd)
+ -- Later: Which never helped...
+-- , ghc-syb-utils ==1.2.1.2
+ , ghc-syb-utils
+-- , ghc ==7.6.*
+ , ghc
+ if flag(USE_DATA_TREE)
+ build-depends: containers
+ hs-source-dirs: src
+ default-language: Haskell2010
+-- if flag(PROFILE)
+-- ghc-options: -fprof-auto -auto-all -caf-all
+-- if flag(OPTIMISE)
+-- ghc-options: -O2
+-- else
+-- ghc-options: -O0
+-- Hackage upload complains:
+--if flag(DYNAMIC)
+-- ghc-options: -dynamic
+ if flag(USE_DATA_TREE)
+ cpp-options: -DUSE_DATA_TREE=1
+ else
+ cpp-options: -DUSE_DATA_TREE=0
+
+ ghc-options: -optP-Wundef -fno-warn-overlapping-patterns -rtsopts
+--ghc-options: -optP-Wundef -fno-warn-overlapping-patterns -rtsopts -threaded
+
+ -- needed?
+ if impl(ghc < 6.12)
+ ghc-options: -package-name syb
+
+--ghc-options: -Wall
+
+-- test-suite unit-tests
+-- type: exitcode-stdio-1.0
+-- hs-source-dirs: tests
+-- main-is: Main.hs
+-- build-depends: base
+-- , syb
+-- , HUnit
+-- , containers
+-- , mtl
+
+test-suite unit-tests
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+-- This WORKS, but the output is all sent to the test log!
+-- However, it was a mistake that I even tried this, and I'm
+-- surprised it worked at all!
+--main-is: test-05.hs
+-- Executable test-sai-shape-syb
+--main-is: test-05.hs
+--other-modules: Random
+ other-extensions: TemplateHaskell
+-- if flag(PROFILE)
+-- ghc-options: -fprof-auto -auto-all -caf-all
+-- if flag(OPTIMISE)
+-- ghc-options: -O2
+-- else
+-- ghc-options: -O0
+-- Hackage upload complains:
+--if flag(DYNAMIC)
+-- ghc-options: -dynamic
+ if flag(USE_DATA_TREE)
+ cpp-options: -DUSE_DATA_TREE=1
+ else
+ cpp-options: -DUSE_DATA_TREE=0
+ ghc-options: -optP-Wundef -fno-warn-overlapping-patterns -rtsopts -threaded
+ build-depends:
+-- XXX VERY BAD!!! (overconstrained)
+--- base >=4.6 && <4.7
+ base >= 4.0 && < 5.0
+-- , containers
+-- -- , containers ==0.5.0.*
+-- -- , containers ==0.5.3.*
+-- , bytestring
+-- -- , bytestring ==0.10.0.*
+-- -- , bytestring ==0.10.4.*
+-- , text
+-- -- , text ==0.11.3.*
+-- -- , text ==1.1.1.1
+-- , filepath
+-- -- , filepath ==1.3.0.*
+-- , directory
+-- -- , directory ==1.2.0.*
+-- -- , binary-generic
+-- -- XXX Note that 0.5 was the one automatically selected, but
+-- -- it does not work for my generic deriving, and specifying
+-- -- 0.7 did not cause any problems (or even warnings)...
+-- -- Everything else went without issues, installing with
+-- -- --enable-*-profiling. As for --enable-shared, can't seem
+-- -- to specify it as we're not building a library [?] -- but,
+-- -- as know from experience, when it comes to that, will HAVE
+-- -- to reinstall everything, as there's no system-wide .o_dyn
+-- -- [or is it .dyn_o?] installed.
+-- -- , binary
+-- -- , binary ==0.5.1.*
+-- , binary ==0.7.1.*
+-- , deepseq-generics
+-- -- , deepseq-generics ==0.1.1.*
+-- -- , deepseq ==1.3.*
+-- , vector
+-- -- , vector ==0.10.0.*
+-- , attoparsec
+-- -- , attoparsec ==0.10.1.*
+-- , ansi-terminal
+-- -- , ansi-terminal ==0.6.1.*
+-- , unordered-containers
+-- -- , unordered-containers ==0.2.3.*
+-- , hashable
+-- -- , hashable ==1.2.1.*
+-- Look into HaRe-as-library, too...
+-- Or just borrow some of their source files...
+ , syb
+ , ghc
+-- , ghc-paths
+ -- version is "phoney" (patch of mine, add-source'd)
+ -- Later: Which never helped...
+-- , ghc-syb-utils ==1.2.1.2
+ , ghc-syb-utils
+ , sai-shape-syb
+ -- XXX only for testing (to make a Data.Map)
+ , containers
+ -- version constraint only b/c not online here...
+ , HUnit ==1.2.5.2
+-- Arbitrary package I *don't* use, to test that
+-- cabal fetch sai-shape-syb.cabal
+-- does resolve and fetch dependencies.
+-- It seems to work! (LATER: On a bigger test, it seems not to fetch all...)
+-- , numeric-limits
+ hs-source-dirs: tests
+ default-language: Haskell2010
+
diff --git a/src/SAI/Data/Generics/Shape.hs b/src/SAI/Data/Generics/Shape.hs
new file mode 100644
--- /dev/null
+++ b/src/SAI/Data/Generics/Shape.hs
@@ -0,0 +1,50 @@
+
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : SAI.Data.Generics.Shape
+-- Copyright : (c) Andrew Seniuk, 2014
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : rasfar@gmail.com
+-- Stability : experimental
+-- Portability : non-portable (uses Data.Generics.Basics)
+--
+-- This package provides SYB shape support: generic fmap to
+-- homogeneous types, and related features. Complements existing
+-- Uniplate and TH shape libraries. See
+-- for more information.
+--
+-- The present module simply re-exports all relevant modules.
+--
+-----------------------------------------------------------------------------
+
+module SAI.Data.Generics.Shape (
+
+ --- * Core SYB exports
+--module SAI.Data.Generics ,
+
+ -- * Generic shape
+ module SAI.Data.Generics.Shape.SYB ,
+
+ -- * Filtering with some structure preservation
+ module SAI.Data.Generics.Shape.SYB.Filter ,
+
+ -- * Generic shape, variants for handling GHC API staged types
+ module SAI.Data.Generics.Shape.SYB.GHC ,
+
+ ) where
+
+------------------------------------------------------------------------------
+
+--import Data.Generics
+
+import SAI.Data.Generics.Shape.SYB
+--import SAI.Data.Generics.Shape.SYB hiding ( R )
+
+import SAI.Data.Generics.Shape.SYB.Filter
+
+-- XXX Could consider a compiler switch for this actually.
+import SAI.Data.Generics.Shape.SYB.GHC
+
diff --git a/src/SAI/Data/Generics/Shape/SYB.hs b/src/SAI/Data/Generics/Shape/SYB.hs
new file mode 100644
--- /dev/null
+++ b/src/SAI/Data/Generics/Shape/SYB.hs
@@ -0,0 +1,763 @@
+
+-------------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+
+-------------------------------------------------------------------------------
+
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveFunctor #-}
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+{- LANGUAGE ImpredicativeTypes #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : SAI.Data.Generics.Shape.SYB
+-- Copyright : (c) Andrew Seniuk, 2014
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : rasfar@gmail.com
+-- Stability : experimental
+-- Portability : non-portable (uses Data.Generics.Basics)
+--
+-- This package provides SYB shape support: generic fmap to
+-- homogeneous types, and related features. Complements existing
+-- Uniplate and TH shape libraries. See
+-- for more information.
+--
+-- The present module provides the main types and functions.
+--
+-----------------------------------------------------------------------------
+
+ module SAI.Data.Generics.Shape.SYB (
+
+ -- * Types
+
+ Homo ,
+ Hetero ,
+ Bi ,
+ Shape ,
+ HomoM ,
+ BiM ,
+
+ -- * Rose Tree Type
+
+#if USE_DATA_TREE
+ Rose ,
+#else
+ Rose(..) ,
+#endif
+-- Hose(..) , -- heterogeneous Rose HList
+
+ -- * Homomorphisms
+
+ ghom ,
+ ghomK ,
+ ghomDyn ,
+ ghomBi ,
+
+ -- * Inverses where possible
+
+ unGhomDyn ,
+ unGhomBi ,
+
+ -- * Conversions
+ -- | These conversion functions should obey at least the following laws.
+ --
+ -- @'ghom' f = 'biToHomo' . 'ghomBi' f@
+ --
+ -- @'biToHetero' . 'ghomBi' g = 'biToHetero' . 'ghomBi' f@
+ --
+ -- @'ghomBi' f = 'heteroToBi' f . 'ghomDyn'@
+ --
+ -- @'ghomBi' g = 'heteroToBi' g . 'biToHetero' . 'ghomBi' f@
+
+#if 1
+ biToHomo ,
+ biToHetero ,
+#else
+ biToHomo_forgetful ,
+ biToHetero_faithful ,
+#endif
+ heteroToBi ,
+
+ -- * Conversions concerning lifted types
+
+ liftHomoM ,
+ liftBiM ,
+ unliftHomoM ,
+ unliftBiM ,
+
+ -- * Progressive refinement and accumulation
+
+ gempty ,
+ grefine ,
+-- grefineG , -- XXX still not rid of compiler instance errors...
+ gaccum ,
+#if 0
+-- gassim ,
+#endif
+
+ -- * For convenience
+
+ shapeOf ,
+-- shapeOf_ , -- can't define here in logical place, due to cyclic imports
+ sizeOf ,
+
+ symmorphic ,
+ (~~) ,
+
+ weightedShapeOf ,
+
+ weightedRose ,
+ weightedRoseJust ,
+
+ sizeOfRose ,
+
+ zipRose ,
+ unzipRose ,
+ zipBi ,
+ unzipBi ,
+
+ zip ,
+ unzip ,
+
+ -- * Showing values
+ -- | Pretty-printing of rose trees, including compact representations. Also, show functions for a subset of Dynamic values, which show the value and not just @\<\<@/type/@\>\>@.
+ --- | In addition to a Show instance for Rose a which pretty-prints the tree, there are several compact representations available. Also, show functions for a subset of Dynamic values, which show the value and not just @\<\<@/type/@\>\>@.
+
+ showHomo ,
+ showHomoM ,
+
+ showAsParens ,
+ showAsParensBool ,
+ showAsParensEnriched ,
+ showAsParensEnrichedM ,
+
+ showDyn ,
+ showHetero ,
+ showBi ,
+
+#if USE_DATA_TREE
+ -- * Re-exported from Data.Tree
+ Tree(Node) , Forest ,
+-- Tree(Node) ,
+-- Rose(Node) ,
+-- Data.Tree.Tree, Data.Tree.Node,
+-- module Data.Tree ,
+#else
+ toDataTree ,
+ fromDataTree ,
+#endif
+
+ ) where
+
+-------------------------------------------------------------------------------
+
+ import Data.Generics.Aliases ( GenericQ )
+ import Data.Generics.Aliases ( mkQ )
+--import Data.Generics.Aliases ( extQ )
+ import Data.Data ( Data, gmapQ )
+ import Data.Dynamic
+ import Data.Maybe
+
+ -- XXX
+ --
+ -- Unfortunately, I think it's impossible to import a data (or type)
+ -- constructor under a different name; nor is it possible to alias
+ -- the name locally. It's a shame -- we'd need toTree and fromTree
+ -- just to gain access to all the standard tree library functionality.
+ -- Even if we make that totally fuse, it's unpleasant.
+ --
+ -- The reason want custom Rose datatype is:
+ -- (1) I like my Show instance better -- is it possible to override
+ -- an instance of an externally-defined datatype?...
+ -- (2) I like my single-character constructor "R" -- if alias
+ -- Data.Tree, will need to substitute "Node" for "R" everywhere.
+ -- (Obviously, I won't be writting CPP branch for this.)
+ --
+ -- I just scourered Data.Typeable[.Internal] and Data.Data again,
+ -- but I don't see how to create a data constructor alias using
+ -- those tools...
+#if USE_DATA_TREE
+ import Data.Tree ( Tree(Node), Forest )
+--import Data.Tree ( Tree(Node) )
+--import qualified Data.Tree ( Tree(Node) )
+#else
+ import qualified Data.Tree ( Tree(Node) ) -- still needed for to/from
+#endif
+
+ import Prelude hiding ( zip, unzip, zipWith )
+ import qualified Prelude as P ( zip, unzip, zipWith )
+ import Control.Applicative ( (<*>) ) -- on its own line b/c looks so cool
+ import Control.Applicative ( Applicative )
+--import Control.Applicative ( Applicative, (<*>) )
+
+ import Debug.Trace ( trace )
+
+-------------------------------------------------------------------------------
+
+ type Homo r = Rose r
+ type Hetero = Homo Dynamic
+ type Bi r = Homo (Dynamic, r)
+ type Shape = Homo ()
+ type HomoM r = Homo (Maybe r)
+ type BiM r = Bi (Maybe r)
+--type Homo = Rose -- seems fine ... but I prefer the explicitly-param'sd
+--type Hetero = Rose HList -- a possible alternative to Dynamic
+
+-------------------------------------------------------------------------------
+
+#if USE_DATA_TREE
+ -- | From "Data.Tree" we have, essentially
+ --
+ -- @data 'Tree' r = 'Node' r ['Tree' r]@
+ type Rose = Data.Tree.Tree
+--R = Data.Tree.Node -- we wish...
+#else
+-- Later: try this:
+--data Rose f r = Node r (f (Rose f r)) deriving (Applicative,Functor)
+ data Rose r = Node r [Rose r] deriving Functor
+--data Rose f r = R r (f (Rose f r)) deriving (Applicative,Functor)
+--data Rose r = R r [Rose r] deriving Functor
+ type Tree = Rose
+
+ instance Show r => Show (Rose r) where
+ show = show' 0
+ where show' n (Node r chs) =
+ indent n ++ show r ++ "\n"
+ ++ concatMap (show' (1+n)) chs
+ where indent n = replicate (2*n) ' '
+
+ -- (was used, but not used at the moment)
+ instance Eq r => Eq (Rose r) where
+ (==) = eq
+ where
+ eq (Node r []) (Node r' []) = r == r'
+ eq (Node _ []) (Node _ _) = False
+ eq (Node _ _) (Node _ []) = False
+ eq (Node r chs) (Node r' chs')
+ = r == r' && and (zipWith eq chs chs')
+#endif
+
+ showHomo :: Show r => Rose r -> String
+ showHomo = show' 0
+ where show' n (Node r chs) =
+ indent n ++ show r ++ "\n"
+ ++ concatMap (show' (1+n)) chs
+ where indent n = concat $ replicate n "| "
+
+ showHomoM :: Show r => Rose (Maybe r) -> String
+ showHomoM = show' 0
+ where show' n (Node mr chs) =
+ ( case mr of
+ Nothing -> indent n ++ "\n"
+ Just r -> indent n ++ show r ++ "\n"
+ ) ++ concatMap (show' (1+n)) chs
+ where indent n = concat $ replicate n "| "
+
+-------------------------------------------------------------------------------
+
+ -- | Map an arbitrary data constructor application expression to
+ -- a homogeneous representation preserving structure.
+ -- This is a one-way trip; what value information is preserved
+ -- depends on the mapping function you provide.
+ -- Use 'ghomDyn' or 'ghomBi' if you need to be able
+ -- to recover the original, heterogeneous data.
+ ghom :: forall r d. Data d => GenericQ r -> d -> Homo r
+ ghom f x = foldl k b (gmapQ (ghom f) x)
+ where
+ b = Node (f x) []
+ k (Node r chs) nod = Node r (chs++[nod])
+
+ -- | Like ghom, but use a custom combining function, instead of
+ -- the default @(\\r _->r)@.
+ ghomK :: forall r d. Data d =>
+ (r -> r -> r)
+ -> GenericQ r
+ -> d
+ -> Homo r
+ ghomK k f x = foldl k' b (gmapQ (ghomK k f) x)
+ where
+ b = Node (f x) []
+ k' (Node r chs) nod@(Node r' _) = Node (r `k` r') (chs++[nod])
+
+ -- | Uses "Data.Dynamic" to support mutiple types homogeneously.
+ -- Unlike 'ghom', this is invertible ('unGhomDyn').
+#if 1
+ ghomDyn :: forall d. Data d => d -> Hetero
+ ghomDyn x = foldl k b (gmapQ ghomDyn x)
+ where
+ b = Node (toDyn x) []
+ k (Node r chs) nod = Node r (chs++[nod])
+#else
+ ghomDyn :: forall r d. (Typeable r, Data d) => GenericQ r -> d -> Hetero
+ ghomDyn f x = foldl k b (gmapQ (ghomDyn f) x)
+ where
+ b = Node (toDyn (x, f x)) []
+ k (Node r chs) nod = Node r (chs++[nod])
+#endif
+
+ -- | @'ghomBi' f x = 'zipRose' ('ghomDyn' x) ('ghom' f x)@
+ --
+ -- Unlike 'ghom', you can recover the original, polytypic term ('unGhomBi').
+ ghomBi :: forall r d. Data d => GenericQ r -> d -> Bi r
+--ghomBi :: forall r d. (Show d, Show r, Data d) => GenericQ r -> d -> Bi r
+#if 1
+ ghomBi f x = zipRose (ghomDyn x) $ ghom f x
+--ghomBi f x = trace (show (ghomDyn x) ++ "\n" ++ show (ghom f x)) $ zipRose (ghomDyn x) $ ghom f x
+#else
+ ghomBi f x = foldl k b (gmapQ (ghomBi f) x)
+ where
+ b = Node (toDyn x, f x) []
+ k (Node r chs) nod = Node r (chs++[nod])
+#endif
+
+-------------------------------------------------------------------------------
+
+ unGhomDyn :: Typeable a => Hetero -> a
+ unGhomDyn (Node xd chs) = fromJust $ fromDynamic xd
+
+ unGhomBi :: Typeable a => Bi r -> a
+ unGhomBi (Node (xd,r) chs) = fromJust $ fromDynamic xd
+
+-------------------------------------------------------------------------------
+
+#if 1
+ -- | Drops the 'Dynamic' component.
+ biToHomo :: Bi r -> Homo r
+ biToHomo (Node (_,r) chs) = Node r (map biToHomo chs)
+
+ -- | Drops the homogeneous component (type @r@).
+ biToHetero :: Bi r -> Hetero
+ biToHetero (Node (d,_) chs) = Node d (map biToHetero chs)
+#else
+ -- | \"Forgetful\" since pre-homomorphism info is discarded.
+ biToHomo_forgetful :: Bi r -> Homo r
+ biToHomo_forgetful (Node (_,r) chs) = Node r (map biToHomo_forgetful chs)
+
+ -- | \"Faithful\" since you can apply 'heteroToBi' with the original
+ -- mapping function to obtain a 'Bi' again.
+ biToHetero_faithful :: Bi r -> Hetero
+ biToHetero_faithful (Node (d,_) chs) = Node d (map biToHetero_faithful chs)
+#endif
+
+ heteroToBi :: forall r d.(Data d,Typeable d,Typeable r) =>
+ r
+ -> (d -> r)
+ -> Hetero -> Bi r
+ heteroToBi z f (Node dc chs) = Node (dc, fx) chs'
+ where
+ chs' = map (heteroToBi z f) chs
+ fg = mkQ z f :: GenericQ r
+ fx | isNothing mrc = z
+ | otherwise = fg rc
+ mrc = fromDynamic dc :: Maybe d
+ rc = fromJust mrc
+
+-------------------------------------------------------------------------------
+
+ -- | Conversion from 'Homo' to 'HomoM' by wrapping values in 'Just'.
+ liftHomoM :: Homo r -> HomoM r
+ liftHomoM = fmap Just
+
+ -- | Analogous to 'liftHomoM'.
+ liftBiM :: Bi r -> BiM r
+ liftBiM (Node (d,r) chs) = Node (d,Just r) $ map liftBiM chs
+
+ -- | Sometimes it makes sense to replace the 'Nothing' nodes with
+ -- a default value in type @r@.
+ --
+ -- The best default value will often be some function
+ -- of the filtered, 'Just' items.
+ --
+ -- @'unliftHomoM' = 'fmap' . 'flip' 'maybe' 'id'@
+ --
+ -- Lineal ordering is preserved among 'Just' nodes.
+ unliftHomoM :: r -> HomoM r -> Homo r
+ unliftHomoM = fmap . flip maybe id
+--unliftHomoM z = fmap (maybe z id)
+
+ -- | Analogous to 'unliftHomoM'.
+ unliftBiM :: r -> BiM r -> Bi r
+ unliftBiM z (Node (d,mr) chs) = Node (d,r) $ map (unliftBiM z) chs
+ where
+ r | isNothing mr = z
+ | otherwise = fromJust mr
+
+-------------------------------------------------------------------------------
+
+ -- | Trivial homomorphism that discards all value information.
+ shapeOf :: forall d. Data d => d -> Shape
+ shapeOf = ghom (const ())
+
+ -- | Generic number of nodes in a polytypic term.
+ sizeOf :: forall d. Data d => d -> Int
+ sizeOf = sizeOfRose . shapeOf
+
+-------------------------------------------------------------------------------
+
+ -- | Compare two rose trees for shape equality.
+ symmorphic :: forall d1 d2. (Data d1,Data d2) => d1 -> d2 -> Bool
+#if 1
+ symmorphic x y = shapeOf x == shapeOf y
+#else
+ symmorphic (Node v1 []) (Node v2 []) = True
+ symmorphic (Node v1 []) (Node v2 _) = False
+ symmorphic (Node v1 _) (Node v2 []) = False
+ symmorphic (Node v1 chs1) (Node v2 chs2)
+ = and $ P.zipWith symmorphic chs1 chs2
+#endif
+
+ -- | Operator synonymous with 'symmorphic'.
+ (~~) :: forall d1 d2. (Data d1,Data d2) => d1 -> d2 -> Bool
+ (~~) = symmorphic
+
+-------------------------------------------------------------------------------
+
+ -- | Number of nodes in a rose tree.
+ sizeOfRose :: Rose a -> Int
+ sizeOfRose (Node _ chs) = 1 + sum (map sizeOfRose chs)
+
+ -- | Combine two rose trees with identical shape, by tupling their values.
+ zipRose :: Rose r -> Rose s -> Rose (r,s)
+#if 0
+ zipRose = zip
+#else
+ zipRose (Node v1 []) (Node v2 []) = Node (v1,v2) [] -- yes it's needed!
+ zipRose (Node v1 []) (Node v2 _) = error "zipRose: differently shaped arguments"
+ zipRose (Node v1 _) (Node v2 []) = error "zipRose: differently shaped arguments"
+ zipRose (Node v1 chs1) (Node v2 chs2) = Node (v1,v2) $ P.zipWith zipRose chs1 chs2
+--zipRose (Node v1 chs1) (Node v2 chs2) = Node (v1,v2) $ zipWith zipRose chs1 chs2
+#endif
+
+#if 1
+ -- Just wrote a bit about the dissymmetry here.
+ -- It seems strange that zip should require Applicative,
+ -- but unzip not require it, since the two representations
+ -- are isomorphic. It wouldn't seem strange if BOTH required
+ -- both Applicative and Functor; but only one requires Applicative...
+ --
+ -- I get the feeling it would be wrong to conclude that, since we
+ -- have an unzip which requires only Functor, it should follow
+ -- there /must/ exist a zip which requires only Functor...
+
+ -- Hey! I did it! I figured out to use Applicative, in a
+ -- nice natural way (my first use of it).
+#if 1
+ -- to make the comparison to unzip better:
+ zip :: (Applicative f, Functor f) => (f a, f b) -> f (a,b)
+ zip (fa, fb) = fmap (\x -> (\y -> (x,y))) fa <*> fb
+#else
+ zip :: (Applicative f, Functor f) => f a -> f b -> f (a,b)
+--zip :: forall a b f. Functor f => f a -> f b -> f (a,b)
+ zip fa fb = fmap (\x -> (\y -> (x,y))) fa <*> fb
+--zip fa fb = (<*>) ( fmap (\x -> (\y -> (x,y))) fa ) fb
+#endif
+
+#if 0
+ zipWith :: Functor f => (a->b->c) -> f a -> f b -> f c
+ zipWith f fa fb = (fmap (\x -> f x) fa) ...
+#else
+ zipWith :: (Applicative f, Functor f) => (a->b->c) -> f a -> f b -> f c
+ zipWith f fa fb = fmap (\x -> (\y -> f x y)) fa <*> fb
+#endif
+
+ -- Now to try for unzip -- and yeah this works; however,
+ -- the unzipRose found an efficient expression. This is 2x
+ -- more work than necessary, on the same idea as unzipRose,
+ -- I'm quite sure... If it was an Arrow, then maybe...
+ unzip :: Functor f => f (a,b) -> (f a, f b)
+--unzip :: (Applicative f, Functor f) => f (a,b) -> (f a, f b)
+ unzip fab = (fmap (\ (x,y) -> x) fab, fmap (\ (x,y) -> y) fab)
+#endif
+
+ -- XXX broken; will I have better luck using a fold?...
+-- Here's unzip from GHC.List:
+{-
+-- | 'unzip' transforms a list of pairs into a list of first components
+-- and a list of second components.
+unzip :: [(a,b)] -> ([a],[b])
+{-# INLINE unzip #-}
+unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])
+-}
+ -- | Inverse of zipRose (up to Currying).
+#if 0
+#elif 0
+ unzipRose :: Rose (r, s) -> (Rose r, Rose s)
+ unzipRose rtree = (left,right)
+ where
+ left = fmap (\(x,y) -> x) rtree
+ right = fmap (\(x,y) -> y) rtree
+--unzipRose' :: Rose (r, s) -> Rose r -> Rose s -> (Rose r, Rose s)
+#elif 1
+ -- accumulating version?
+ unzipRose :: Rose (r, s) -> (Rose r, Rose s)
+ unzipRose (Node (x,y) ns) = (Node x xns, Node y yns)
+ where
+ (xns,yns) = unzip $ map unzipRose ns
+-- (xns,yns) = P.unzip $ map unzipRose ns
+#elif 0
+ -- This clearly cannot work!
+ unzipRose :: Rose (r, s) -> (Rose r, Rose s)
+ unzipRose (Node (v1,v2) []) = (Node v1 [], Node v2 []) -- yes it's needed!
+ unzipRose (Node (v1,v2) chs) = Node (v1,v2) $ map unzipRose chs
+ unzipRose' :: Rose (r, s) -> Rose r -> Rose s -> (Rose r, Rose s)
+ unzipRose' (Node (v1,v2) []) acc_r acc_s = (acc_r,acc_s)
+ unzipRose' (Node (v1,v2) chs) acc_r acc_s = map unzipRose chs
+#endif
+
+ -- | Zip two 'Bi's. It is the caller's responsibility to assure that
+ -- the 'Dynamic' component is the same in both arguments (in addition
+ -- to assuring that the shapes are compatible).
+ zipBi :: Bi r -> Bi s -> Bi (r,s)
+ zipBi (Node (d,v1) []) (Node (_,v2) []) = Node (d,(v1,v2)) [] -- yes it's needed!
+ zipBi (Node (d,v1) []) (Node (_,v2) _) = error "zipBi: differently shaped arguments"
+ zipBi (Node (d,v1) _) (Node (_,v2) []) = error "zipBi: differently shaped arguments"
+ zipBi (Node (d,v1) chs1) (Node (_,v2) chs2) = Node (d,(v1,v2)) $ zipWith zipBi chs1 chs2
+
+ unzipBi :: Bi (r, s) -> (Bi r, Bi s)
+ unzipBi (Node (d,(x,y)) ns) = (Node (d,x) xns, Node (d,y) yns)
+ where
+ (xns,yns) = unzip $ map unzipBi ns
+
+ -- | Produce a zipped rose tree, where the second component
+ -- at a node is the number of non-'Nothing' (/i.e./ 'Just') descendants,
+ -- plus one for itself if it is 'Just'.
+ weightedRoseJust :: Rose (Maybe r) -> Rose (Maybe r, Int)
+ weightedRoseJust (Node Nothing []) = Node (Nothing,0) []
+ weightedRoseJust (Node (Just v) []) = Node (Just v,1) []
+ weightedRoseJust (Node v chs) = Node (v,n) chs'
+ where
+ chs' = map weightedRoseJust chs -- :: [ Homo (Maybe r, Int) ]
+ -- XXX where's our base case?!
+ n = sum $ map (\ (Node (_,m) _) -> m) chs'
+
+-------------------------------------------------------------------------------
+
+ -- | Weight of a node is defined as the number of descendants, plus 1.
+ weightedShapeOf :: forall d. Data d => d -> Homo Int
+ weightedShapeOf = ghomK (+) (const 1)
+
+ -- Almost got away with using ghomK, but it would require
+ -- Data r constraint, which is otherwise bad.
+ weightedRose :: Rose r -> Rose (r, Int)
+ weightedRose (Node r chs) = foldl k' b (map weightedRose chs)
+ where
+ k = (\ (r,w) (r',w') -> (r,w+w'))
+ f = (\ r -> (r,1))
+ b = Node (r,1) []
+ k' (Node rw chs) nod@(Node rw' _) = Node (rw `k` rw') (chs++[nod])
+
+-------------------------------------------------------------------------------
+
+ showAsParens :: Homo r -> String
+ showAsParens (Node _ chs) = "(" ++ concatMap showAsParens chs ++ ")"
+
+ showAsParensBool :: Homo Bool -> String
+ showAsParensBool (Node r chs) = "(" ++ (if r then "*" else ".") ++ concatMap showAsParensBool chs ++ ")"
+--showAsParensBool (Node r chs) = "(" ++ (if r then "T" else "F") ++ concatMap showAsParensBool chs ++ ")"
+
+ showAsParensEnriched :: Show r => Homo r -> String
+ showAsParensEnriched (Node r chs) = "(" ++ show r ++ concatMap showAsParensEnriched chs ++ ")"
+
+ showAsParensEnrichedM :: Show r => HomoM r -> String
+ showAsParensEnrichedM (Node Nothing chs) = "(" ++ concatMap showAsParensEnrichedM chs ++ ")"
+ showAsParensEnrichedM (Node (Just r) chs) = "(" ++ show r ++ concatMap showAsParensEnrichedM chs ++ ")"
+
+-------------------------------------------------------------------------------
+
+-- XXX There is no satisfactory solution here yet.
+-- What we want is, to use the type's natural show when it's
+-- an instance of Show, and otherwise use Dynamic's Show instance.
+#if 0
+#elif 0
+ -- Doesn't work, unfortunately.
+ showDyn :: Dynamic -> String
+ showDyn xd
+--- | typeOf x == typeOf (undefined::Show a => a) = show x -- would be nice!
+ | test mx (undefined::Int) = show (fromJust mx::Int)
+ | test mx (undefined::[Int]) = show (fromJust mx::[Int])
+ | test mx (undefined::[[Int]]) = show (fromJust mx::[[Int]])
+ | otherwise = show xd -- use default Dynamic show instance
+ where
+ test m val = isJust m && typeOf (fromJust m) == typeOf val
+ mx = fromDynamic xd
+#elif 1
+ -- Working!
+ showDyn :: Dynamic -> String
+ showDyn xd
+--- | typeOf x == typeOf (undefined::Show a => a) = show x -- would be nice!
+ | test mx_Int (undefined::Int) = show (fromJust mx_Int::Int)
+ | test mx_LInt (undefined::[Int]) = show (fromJust mx_LInt::[Int])
+ | test mx_LLInt (undefined::[[Int]]) = show (fromJust mx_LLInt::[[Int]])
+ | otherwise = show xd -- use default Dynamic show instance
+ where
+ test mx val = isJust mx && typeOf (fromJust mx) == typeOf val
+ mx_Int = fromDynamic xd
+ mx_LInt = fromDynamic xd
+ mx_LLInt = fromDynamic xd
+#else
+ -- Doesn't work for me...
+ showDyn :: Dynamic -> String
+ showDyn xd
+ | isNothing mx = show xd -- use default Dynamic show instance
+ | otherwise = show x -- use the instance for the Showable type
+ where
+ mx = fromDynamic xd :: (Show a,Typeable a) => Maybe a
+ x = fromJust mx
+#endif
+
+ showHetero :: Hetero -> String
+ showHetero = showHetero' 0
+ where
+ showHetero' n (Node d chs)
+ = indent n ++ showDyn d ++ "\n"
+ ++ concatMap (showHetero' (1+n)) chs
+ where
+ indent n = replicate (2*n) ' '
+
+ showBi :: Show r => Bi r -> String
+ showBi = showBi' 0
+ where
+ showBi' n (Node (d,r) chs)
+ = indent n ++ "(" ++ showDyn d ++ ", " ++ show r ++ ")" ++ "\n"
+ ++ concatMap (showBi' (1+n)) chs
+ where
+ indent n = replicate (2*n) ' '
+
+-------------------------------------------------------------------------------
+
+#if ! USE_DATA_TREE
+
+ -- | Provided so we can use 'R' for node constructor, and
+ -- so that the Show instance is nicer.
+#if 1
+ toDataTree :: Rose a -> Data.Tree.Tree a
+ toDataTree (Node v chs) = Data.Tree.Node v $ map toDataTree chs
+#else
+-- (tried numerous other things too; trying to use higher-order)
+ toDataTree :: forall a. (Typeable a, Rose a) => Rose a -> Data.Tree.Tree a
+ toDataTree = fmap (\v -> fromJust $ cast v :: Data.Tree.Tree a)
+--toDataTree = gmap (\v -> fromJust $ cast v :: Data.Tree.Tree a)
+#endif
+
+ fromDataTree :: Data.Tree.Tree a -> Rose a
+ fromDataTree (Data.Tree.Node v chs) = Node v $ map fromDataTree chs
+
+#endif
+
+-------------------------------------------------------------------------------
+
+ -- Why is it r that needs to be typeable??...
+ -- | Sets up a @'BiM' r@ using a default 'GenericQ' which
+ -- assigns all values to 'Nothing'.
+ --
+ -- Use an expression type signature at the call site, to constrain
+ -- the type @r@ (the usual trick)
+ --
+ -- > ( gempty x :: BiM ( Int , Data.IntMap Text , [Float] ) )
+ --
+ -- so your choice type @r@ is a triple, but the @'BiM' r@ value
+ -- returned contains 'Nothing' at every node. This prepares it
+ -- for refinement and accumulation.
+ gempty :: forall r d. (Typeable r,Data d) => d -> BiM r
+--gempty :: forall r d. (Show r,Typeable r,Show d,Data d) => d -> BiM r
+ gempty = ghomBi (mkQ Nothing id)
+
+ -- XXX This should call gaccum if possible, rather than clone?...
+ -- | Given a monomorphic function you provide, returning r,
+ -- automatically makes a @'GenericQ' r@ from this. It then maps
+ -- the generic query over the source polytypic tree, the latter
+ -- being recovered from the 'Dynamic' component of the 'BiM'.
+ --
+ -- The target is updated with write-once semantics enforced;
+ -- that is to say, 'grefine' will throw an exception if it finds
+ -- a 'Just' already present at any place in the result tree that
+ -- it would update.
+ grefine :: forall r d. (Typeable r,Data d,Typeable d) => (d -> Maybe r) -> BiM r -> BiM r
+--grefine :: forall r d. (Typeable r,Data d,Typeable d) => (d -> r) -> BiM r -> BiM r
+--grefine :: forall r a d. (Typeable a,Data d) => (a -> r) -> BiM r -> BiM r
+--grefine :: Typeable a => (a -> r) -> BiM r -> BiM r
+ grefine f x = x'
+ where
+ f' = f -- :: d -> Maybe r
+ fg = mkQ Nothing f' :: d -> Maybe r
+ x' = grefine' x
+ where
+-- grefine' ::
+ grefine' (Node (xd,mr) chs) = x'
+ where
+ x' = Node (xd,r') $ map grefine' chs
+ md = fromDynamic xd :: Maybe d
+ r' | isNothing md = Nothing
+ | isNothing mr = fg $ fromJust md
+ | otherwise = error "grefine: multiple updates attempted at a node"
+#if 0
+ Node (xd,mr) chs = x
+ x' = Node (xd,r') $ map grefine chs
+ r' | isNothing mr = fg $ fromJust $ (fromDynamic xd :: Maybe d)
+ | otherwise = error "grefine: multiple updates attempted at a node"
+#endif
+
+-- XXX Not working yet!
+#if 0
+--grefineG :: forall r d. (Typeable r,Data d) => (d -> Maybe r) -> BiM r -> BiM r
+ grefineG :: forall r d. (Typeable r,Data d,Typeable d) => (d -> Maybe r) -> BiM r -> BiM r
+ grefineG fg x = x'
+ where
+ x' = grefine' x
+ where
+-- grefine' ::
+ grefine' (Node (xd,mr) chs) = x'
+ where
+ x' = Node (xd,r') $ map grefine' chs
+ md = fromDynamic xd :: Maybe d
+ r' | isNothing md = Nothing
+ | isNothing mr = fg $ fromJust md
+ | otherwise = error "grefine: multiple updates attempted at a node"
+#endif
+
+ -- | Like 'grefine', but rather than throw exception, it
+ -- takes a combining function argument to cope with that situation.
+ gaccum :: forall r d. (Typeable r,Data d,Typeable d) =>
+ (r -> r -> r) -> (d -> Maybe r) -> BiM r -> BiM r
+ gaccum k f x = x'
+ where
+ fg = mkQ Nothing f :: d -> Maybe r
+ x' = gaccum' x
+ where
+-- gaccum' ::
+ gaccum' (Node (xd,mr) chs) = x'
+ where
+ md = fromDynamic xd :: Maybe d
+ r = fromJust mr
+ mr_ = fg $ fromJust md
+ r_ = fromJust mr_
+#if 0
+#elif 1
+ mr' | isNothing md = mr
+ | isNothing mr_ = mr
+ | isNothing mr = mr_
+ | otherwise = Just $ r `k` r_
+#elif 0
+-- mr' | isNothing md = trace "*1*" $ Nothing -- why does this seem to stop recursion?
+ mr' | isNothing md = trace "*1*" $ mr
+ | isNothing mr_ = trace "*2*" $ mr
+ | isNothing mr = trace "*3*" $ mr_
+ | otherwise = trace "*4*" $ Just $ r `k` r_
+#elif 0
+ mr' | isNothing md = Nothing
+ | isNothing mr_ = Nothing
+ | isNothing mr = mr_
+ | otherwise = Just $ r `k` r_
+#endif
+ x' = Node (xd,mr') $ map gaccum' chs
+
+--gassim :: ...
+
+-------------------------------------------------------------------------------
+
diff --git a/src/SAI/Data/Generics/Shape/SYB/Filter.hs b/src/SAI/Data/Generics/Shape/SYB/Filter.hs
new file mode 100644
--- /dev/null
+++ b/src/SAI/Data/Generics/Shape/SYB/Filter.hs
@@ -0,0 +1,685 @@
+
+-------------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+
+-------------------------------------------------------------------------------
+
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveFunctor #-}
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+{- LANGUAGE ImpredicativeTypes #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : SAI.Data.Generics.Shape.SYB.Filter
+-- Copyright : (c) Andrew Seniuk, 2014
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : rasfar@gmail.com
+-- Stability : experimental
+-- Portability : non-portable (uses Data.Generics.Basics)
+--
+-- This package provides SYB shape support: generic fmap to
+-- homogeneous types, and related features. Complements existing
+-- Uniplate and TH shape libraries. See
+-- for more information.
+--
+-- The present module provides limited support for structure-changing
+-- transformations, some generic, others on the homogeneous types.
+--
+-----------------------------------------------------------------------------
+
+ module SAI.Data.Generics.Shape.SYB.Filter (
+
+ -- * Lifted result, but good structure preservation (via glue nodes)
+ -- | These functions simplify the structure by removing all possible
+ -- 'Nothing' nodes, without disrupting the lineal relations obtaining
+ -- between 'Just' nodes.
+ --
+ -- Recall that
+ --
+ -- @type 'HomoM' r = 'Homo' ('Maybe' r)@
+ --
+ -- and
+ --
+ -- @type 'BiM' r = 'Bi' ('Maybe' r) = 'Homo' ('Dynamic', ('Maybe' r))@
+ --
+ -- See "Shape.SYB" for other functions involving 'HomoM' and 'BiM'.
+
+ filterHomoM ,
+ filterBiM ,
+
+ -- * Lifted argument, as well as result; same transformation
+ -- | Note that these functions don't take a predicate;
+ -- the filtering predicate is encoded in the @'Maybe' r@ input.
+
+ filterHomoMM ,
+ filterBiMM ,
+
+ -- * Unlifted result, but less structure preserved (no glue nodes)
+ -- | These filter functions produce trees containing only nodes
+ -- which satisfy the predicate, and yet which inherit the structure
+ -- of the argument to some extent.
+ --
+ -- For each node N, the algorithm acts on all children C of N which
+ -- fail the predicate. The transformation is to move the
+ -- grandchildren of N via C into child position, in place of C,
+ -- which is elided. Recurse to fixed point. (You'd think one of
+ -- bottom-up or top-down would do it in one pass, but ... maybe I
+ -- did something wrong...)
+ --
+ -- Other transformations are possible; see also 'filterHomoM_.
+
+ filterHomo ,
+ filterHetero ,
+ filterBi ,
+
+ -- * Lifted argument, less structure preservation (no glue nodes)
+ -- | These don't require a predicate or default values, depending
+ -- instead on 'Nothing' for default, and on the predicate being
+ -- encoded as 'Nothing' / 'Just'.
+
+ filterHomoM_ ,
+ filterHomoM_' ,
+
+ -- * Experimental...
+
+ gfilter ,
+ gfilter_ ,
+ mkQP , -- XXX unfortunately the user must deal with this
+
+ shapeOf_ ,
+
+ ) where
+
+-------------------------------------------------------------------------------
+
+ import Data.Data ( cast )
+ import Data.Data ( gfoldl )
+ import Data.Data ( gmapQ )
+ import Data.Data ( Data )
+ import Data.Data ( Typeable )
+ import Data.Generics.Aliases ( GenericQ )
+ import Data.Generics.Aliases ( mkQ )
+ import Data.Generics.Aliases ( extQ )
+--import Data.Function ( fix )
+ import Data.Dynamic
+--import Data.HList
+ import Data.Maybe
+
+ import SAI.Data.Generics.Shape.SYB
+
+ import Debug.Trace ( trace )
+
+-------------------------------------------------------------------------------
+
+ filterHomo :: (r -> Bool) -> Homo r -> Homo r
+ filterHomo p = condenseHomo (filterHomo' p)
+
+--filterHetero :: (r -> Bool) -> Hetero -> Hetero
+ filterHetero :: Typeable r => (r -> Bool) -> Hetero -> Hetero
+--filterHetero :: (Show r,Typeable r) => (r -> Bool) -> Hetero -> Hetero
+--filterHetero p = condenseHetero (trace "==================" $ filterHetero' p)
+ filterHetero p = condenseHetero (filterHetero' p)
+
+ filterBi :: (r -> Bool) -> Bi r -> Bi r
+ filterBi p = condenseBi (filterBi' p)
+
+-------------------------------------------------------------------------------
+
+ filterHomo' :: (r -> Bool) -> Homo r -> Homo r
+ filterHomo' p (Node rp chsp) = Node rp chsp' -- XXX root stays...
+ where
+ chsp' = map (filterHomo' p) $ concatMap f chsp -- top-down
+-- chsp' = concatMap f chsp -- bottom-up
+ -- How come these all give errors? (see also filterBi')
+-- f :: Rose r -> [ Rose r ]
+-- f :: Homo r -> [ Homo r ]
+-- f :: Homo r' -> [ Homo r' ]
+ f c@(Node rc chsc)
+ | p rc = [c]
+ | otherwise = chsc'
+ where
+ chsc' = chsc -- top-down
+-- chsc' = map (filterHomo' p) chsc -- bottom-up
+
+--filterHetero' :: (r -> Bool) -> Hetero -> Hetero
+ filterHetero' :: Typeable r => (r -> Bool) -> Hetero -> Hetero
+--filterHetero' :: (Show r,Typeable r) => (r -> Bool) -> Hetero -> Hetero
+ filterHetero' p (Node d chsp) = Node d chsp' -- XXX root stays...
+ where
+ chsp' = map (filterHetero' p) $ concatMap f chsp
+ -- It seems this one does not give an error (no type vars?):
+ f :: Rose Dynamic -> [ Rose Dynamic ]
+ f c@(Node dc chsc)
+#if 1
+ | isNothing mrc = chsc'
+ | p rc = [c]
+ | otherwise = chsc'
+#else
+ | isNothing mrc = trace ("*1> "++showDyn dc) $ chsc'
+ | p rc = trace ("*2> "++showDyn dc) $ [c]
+ | otherwise = trace ("*3> "++showDyn dc) $ chsc'
+#endif
+ where
+-- mrc = cast dc :: Typeable r => Maybe r
+-- mrc = cast dc
+ mrc = fromDynamic dc
+ rc = fromJust mrc
+ chsc' = chsc
+
+ filterBi' :: (r -> Bool) -> Bi r -> Bi r
+ filterBi' p (Node (d,rp) chsp) = Node (d,rp) chsp' -- XXX root stays...
+ where
+ chsp' = map (filterBi' p) $ concatMap f chsp
+ -- How come these all give errors?
+-- f :: Rose (Dynamic,r) -> [ Rose (Dynamic,r) ]
+-- f :: Bi r' -> [ Bi r' ]
+-- f :: Bi r -> [ Bi r ]
+-- f :: forall r. Bi r -> [ Bi r ]
+-- f :: forall r'. Bi r' -> [ Bi r' ]
+ f c@(Node (_,rc) chsc)
+ | p rc = [c]
+ | otherwise = chsc'
+ where
+ chsc' = chsc
+
+-------------------------------------------------------------------------------
+
+ -- condense can (in principle) diverge, so watch your algorithm...
+
+ condenseHomo :: (Homo a -> Homo a) -> Homo a -> Homo a
+ condenseHomo = condenseRose
+ condenseHetero :: (Hetero -> Hetero) -> Hetero -> Hetero
+ condenseHetero = condenseRose
+ condenseBi :: (Bi a -> Bi a) -> Bi a -> Bi a
+ condenseBi = condenseRose
+
+ -- Had kept the original Eq versions; but there's simply no point,
+ -- as the values are never changed by the algorithm!
+ -- See cotemp (20140616131313) ./t01...
+
+-------------------------------------------------------------------------------
+
+ -- I started by assuming the "fix" function would be appropriate,
+ -- then didn't figure out how to use it. Then I wrote this; although
+ -- Math.Sequence.Converge could be used, it's such little code for
+ -- and extra library dep. I toyed with names "myfix", "converge",
+ -- "limit", and finally settled on "condense".
+
+ condenseRose :: (Rose a -> Rose a) -> Rose a -> Rose a -- can diverge!...
+ condenseRose f z = condenseRose' $ iterate f z
+--condenseRose f z = condenseRose' $ ( iterate f z :: [ Rose a ] )
+ where
+ -- It would be preferable to accumulate the size info with f,
+ -- that is, to wrap f into an f' which also accumulates and
+ -- returns the size; there's no excuse to traverse it twice,
+ -- and I highly doubt this will fuse...
+ condenseRose' :: [ Rose a ] -> Rose a
+ condenseRose' (x:y:t) | sizeOfRose x == sizeOfRose y = x
+ | otherwise = condenseRose' (y:t)
+ -- no other cases needed -- we know the argument is infinite
+
+ -- May as well provide it since it makes sense and is the most general:
+ condenseEq :: Eq a => (a -> a) -> a -> a -- can diverge!...
+ condenseEq f z = condenseEq' $ iterate f z
+ where
+ condenseEq' (x:y:t) | x == y = x
+ | otherwise = condenseEq' (y:t)
+-- condenseEq' [x] = x
+-- condenseEq' [] = error "condenseEq: empty list"
+ -- no other cases needed -- we know the argument is infinite
+ -- (this function must not be exported for this reason, however)
+
+-------------------------------------------------------------------------------
+
+-- ============================================================================
+--
+-- Experimental code follows!...
+--
+-- ============================================================================
+
+-------------------------------------------------------------------------------
+
+ -- | Later yet: It didn't quite work out. (However, using Dynamic
+ -- may be a way to get around?) The trouble is, the user ...
+ -- actually there\'s one more thing I can test ... was thinking
+ -- about this while falling asleep -- how to automatically
+ -- \"lift and extend\" a user-defined non-generic function
+ --
+ -- @f :: SomeType -> Result@
+ --
+ -- to
+ --
+ -- @f :: SomeType -> Maybe Result@
+ --
+ -- also automatically providing the default case (which the user
+ -- can't provide without either lifting their type themself, or
+ -- constructing some value of type (can use undefined?...)
+ -- Going to try this possibility first... In a \"gfilter2\".
+ --
+ -- Later:
+ -- Do the following procedure:
+ -- (Going to try allowing passing of non-generic p and f, first.
+ -- However, if would have used extQ, this will not allow it...)
+ --
+ -- 1. Wrap f to f', which uses Maybe r.
+ --
+ -- 2. Do the generic homomorphism to Maybe r, using Nothing
+ -- for a node iff the predicate fails.
+ --
+ -- 3. Call filterHomo on the result (Homo (Maybe a)),
+ -- with predicate (not . isNothing).
+ --
+ -- 4. Unwrap Homo (Maybe a) result of 3., to final Homo a result.
+ --
+ -- Old comments:
+ -- Intended for use with fully generic predicate, NOT as
+ -- a stop condition, but as a structure-modifying tree rewrite
+ -- as done for filterHomo. Nodes are retained if and only if
+ -- they satisfy the predicate. An effort is made to preserve
+ -- structure, it's simple enough to be in the canonical regime,
+ -- but other transformations are possible.
+ -- It seems the caller must also call mkQP?
+ gfilter ::
+ forall r d. Data d =>
+ -- forall r d. (Show r, Data d) =>
+-- forall r d. (Show r, Eq r, Data d) =>
+-- forall r d. (Eq r, Data d) =>
+-- (forall d. (Data d, Typeable d) => d -> Bool)
+-- GenericQ Bool
+--- -> (r -> r -> r)
+ (forall d. (Data d, Typeable d) => d -> Maybe r)
+-- GenericQ r
+ -> d
+ -> [Homo r]
+ gfilter fmk x =
+#if 0
+#elif 1
+ filterHomoM_ $ ghom fmk x
+#elif 0
+ ( filterHomoM_
+ $ ghom fmk x ) :: [ Homo r ]
+#elif 0
+ map (fmap fromJust)
+ $ ( ( filterHomoM_ (not . isNothing)
+ $ ( ghom fmk x ) :: HomoM r ) :: [ HomoM r ] )
+#endif
+
+ -- | Analogous to 'gfilter', but takes a default value in @r@ and
+ -- returns a single tree (instead of a forest). Uses 'filterHomoM_''.
+ gfilter_ ::
+ forall r d. Data d =>
+ -- forall r d. (Show r, Data d) =>
+-- forall r d. (Show r, Eq r, Data d) =>
+ r
+ -> (forall d. (Data d, Typeable d) => d -> Maybe r)
+ -> d
+ -> Homo r
+ gfilter_ rdflt fmk x =
+ ( filterHomoM_' rdflt
+ $ ghom fmk x ) :: Homo r
+
+ -- | Another alternative (may not work):
+ -- Take non-generic predicate and transform, and do here all of:
+ -- - lifting to Maybe
+ -- - providing the default case needed by mkQ
+ -- - doing mkQ on the predicate and transform
+ -- This has obvious appeal as the API user need not use
+ -- and generics functions directly. However, a weakness
+ -- is, only a single type for predicate, and only a single
+ -- (possibly other) type for the transform, can be dealt with.
+ -- So there is also gfilter3 which takes generic predicate
+ -- and function, so the user can use extQ as needed to cover
+ -- more than a single type.
+ -- There may be an even better way, maybe using Data.Dynamic?...
+#if 0
+ gfilter2 ::
+ forall r d. (Show r, Data d) =>
+-- forall r d. (Show r, Eq r, Data d) =>
+-- forall r d. (Eq r, Data d) =>
+#if 1
+ ((Data d, Typeable d) => d -> Bool)
+ ((Data e, Typeable e) => e -> r)
+#else
+-- (forall d. (Data d, Typeable d) => d -> Bool)
+ (forall d. (Data d, Typeable d) => d -> r)
+-- GenericQ r
+#endif
+ -> d
+ -> [Homo r]
+ gfilter2 f x = filterHomoM_ $ ghom fmk x
+#endif
+
+#if 0
+ -- | XXX This is not working yet. Is it possible? Not clear from
+ -- the errors whether it can't be done, or it's just my mistakes...
+ ---------
+ -- Similar to gfilter2, but slightly less automated:
+ -- The user must provide generic predicate and transform,
+ -- prepared upstream using mkQ -- however, they may omit
+ -- the default case! (If they include it it's okay.)
+ -- The default case for predicate is always p x = False.
+ -- The default for transform CAN perhaps be f x = undefined.
+ --
+ -- Maybe it won't make sense to have a generic predicate...
+ gfilter3 ::
+ forall r d d1 d2. ({-Data r,-} Typeable r, Show r,
+-- forall r d d1 d2. ({-Data r,-} Typeable r, Show r, Eq r,
+ Data d, Data d1, Data d2,
+ Typeable d, Typeable d1, Typeable d2) =>
+ (d1 -> Bool)
+ -> (d2 -> r)
+ -> d
+ -> [Homo r]
+ gfilter3 pg fg x = filterHomoM_ $ ghom fmk x
+ where
+#if 0
+#elif 0
+ f'' = cast fg :: Maybe (d2 -> Maybe r)
+#elif 1
+ f'' = cast fg :: Maybe (forall d3. (Data d3, Typeable d3) => d3 -> Maybe r)
+#elif 0
+ f'' = cast fg
+#elif 0
+ f'' = fg
+#elif 0
+ f' = unmkQ fg
+ f'' | ...
+#endif
+-- fmk = mkQ Nothing $ fromJust f'' :: d2 -> Maybe r
+-- fmk = mkQ Nothing $ ( ( fromJust f'' ) :: d2 -> Maybe r ) :: d2 -> Maybe r
+-- fmk = mkQ Nothing $ ( ( fromJust f'' ) :: d2 -> Maybe r ) :: (forall d3. Data d3 => d3 -> Maybe r)
+ fmk = mkQ Nothing $ fromJust f''
+#endif
+
+-------------------------------------------------------------------------------
+
+ -- | Would like to be able to call this automatically from gfilter,
+ -- but I think the user code must call it, and pass the result
+ -- to gfilter...
+#if 0
+#elif 0
+ -- nope (compiles, but get type errors when try to use)
+ mkQP :: forall r a. Typeable a =>
+ (r -> Bool)
+ -> (a -> Maybe r)
+ -> a
+ -> Maybe r
+#elif 0
+ -- nope
+ mkQP :: forall r a. Typeable a =>
+ (r -> Bool)
+ -> (forall b. Typeable b => b -> Maybe r)
+ -> a
+ -> Maybe r
+#elif 0
+ -- nope
+ mkQP :: forall r t. ( Typeable t
+-- , Eq r
+ )
+ =>
+ (r -> Bool)
+ -> (forall u. Typeable u => u -> Maybe r)
+ -> t
+ -> Maybe r
+#elif 1
+ -- This one works.
+ -- You don't need the quantification, if you drop the explicit
+ -- expression sig (:: Maybe b) in the function definition.
+ mkQP :: forall r a b.
+ ( Typeable a
+ , Typeable b
+-- , Eq r
+ )
+ =>
+ (r -> Bool)
+-- (forall c. Data c => c -> Bool)
+ -> (b -> Maybe r)
+-- -> (b -> r)
+ -> a
+ -> Maybe r
+#endif
+ mkQP p br a = case cast a :: Maybe b of
+ Just b -> let brb = br b in
+ if isNothing brb
+ then Nothing
+ else if p (fromJust brb)
+ then brb
+ else Nothing
+ Nothing -> Nothing
+
+-------------------------------------------------------------------------------
+
+ -- | 'filterHomoM_' acts on a lifted type to avoid needing to
+ -- specify any default values; however, the root node cannot
+ -- be eliminated by this algorithm, so in case the root is
+ -- a 'Nothing', we need to return its child branches as a forest.
+ filterHomoM_ :: HomoM r -> [Homo r]
+--filterHomoM_ :: Show r => HomoM r -> [Homo r]
+ filterHomoM_ x
+--- | trace (show final) $ False = undefined
+ | otherwise = map (fmap fromJust) forest
+ where
+ p = not . isNothing
+ forest
+ | p r_root = [final]
+ | otherwise = chs_root
+#if 0
+ final@(Node r_root chs_root) = condenseHomo (filterHomo' p) x
+#else
+ -- Needed! (and the error hasn't fired so far...)
+ final@(Node r_root chs_root) = prune $ condenseHomo (filterHomo' p) x
+ prune (Node r chs) = Node r (map prune chs')
+ where
+ chs' = filter pp chs
+ pp (Node rx chsx)
+ | null chsx = not $ isNothing rx
+ | otherwise = error "filterHomo-prune: interior non-root Nothing!"
+#endif
+
+ -- | 'filterHomoM_' plus a root default value in the homogeneous type;
+ -- this allows us to always return a single rooted tree in type @'Homo' r@.
+ -- Compare to 'filterHomoM_' which, lacking such a root default,
+ -- is obliged to return @['Homo' r]@.
+ filterHomoM_' :: r -> HomoM r -> Homo r
+--filterHomoM_' :: Show r => r -> HomoM r -> Homo r
+ filterHomoM_' rdflt x
+ | null forest = error "filterHomoM_': null forest"
+ | length forest > 1 = Node rdflt forest
+ | otherwise = head forest -- this sucks (not just b/c it's
+ -- using "unsafe" head -- it's safe here
+ -- for the moment, as semantically we
+ -- know it's non-empty if get to this case;
+ -- but such code is fragile, since cases
+ -- have a tendency to see code change, which
+ -- can be arbitrarily lexically-decoupled
+ -- from the head call; and it just sucks
+ -- for being so inexpressive/obscure...
+ where
+ forest = filterHomoM_ x
+
+-------------------------------------------------------------------------------
+
+ -- | Tolerate lifted nodes in the result, in exchange for
+ -- better structure preservation.
+ --
+ -- Lineal ordering is preserved among 'Just' nodes.
+ --
+ -- In the end, this is probably the most useful (unless one that
+ -- takes a generic predicate, and acts on original types obtained
+ -- via fromDyn[amic]...).
+ filterHomoM :: (r -> Bool) -> Homo r -> HomoM r
+ filterHomoM p x = x''
+ where
+ p' y = if p y
+ then Just y
+ else Nothing
+ x_ = fmap p' x
+-- x_ = fmap (\ r -> p' r ) x
+ -- XXX oops, we don't even need the weights, done this way...
+ x' = condenseHomo defuzz x_
+ -- Surely can do bottom-up and avoid iterating, but let's
+ -- get a correct output first!...
+ defuzz :: HomoM r -> HomoM r
+ defuzz (Node v chs) = Node v $ map defuzz chs'
+ where
+ chs' = filter g chs
+ g (Node Nothing []) = False
+ g _ = True
+ x'' = condenseHomo contractGlue x'
+-- x'' = trace ("FOO"++show x'++"BAR") $ contractGlue x'
+-- x'' = contractGlue x'
+ contractGlue :: HomoM r -> HomoM r
+ contractGlue (Node r chs) = Node r $ map contractGlue chs'
+ where
+ chs' = map contractNothing1 chs
+ contractNothing1 (Node Nothing [ch@(Node _ chs)]) = ch
+ contractNothing1 v = v
+
+ -- | As per 'filterHomoM', but we string along the 'Dynamic' component.
+ filterBiM :: (r -> Bool) -> Bi r -> BiM r
+ filterBiM p x = x''
+ where
+ p' y = if p y
+ then Just y
+ else Nothing
+ x_ = fmap (\ (d,r) -> (d,p' r) ) x
+ -- XXX oops, we don't even need the weights, done this way...
+ x' = condenseBi defuzz x_
+ -- Surely can do bottom-up and avoid iterating, but let's
+ -- get a correct output first!...
+ defuzz :: BiM r -> BiM r
+ defuzz (Node v chs) = Node v $ map defuzz chs'
+ where
+ chs' = filter g chs
+ g (Node (_,Nothing) []) = False
+ g _ = True
+ x'' = condenseBi contractGlue x'
+-- x'' = trace ("FOO"++show x'++"BAR") $ contractGlue x'
+-- x'' = contractGlue x'
+ contractGlue :: BiM r -> BiM r
+ contractGlue (Node r chs) = Node r $ map contractGlue chs'
+ where
+ chs' = map contractNothing1 chs
+ contractNothing1 (Node (_,Nothing) [ch@(Node _ chs)]) = ch
+ contractNothing1 v = v
+
+-------------------------------------------------------------------------------
+
+ -- | Tolerate lifted nodes in the result, in exchange for
+ -- better structure preservation.
+ --
+ -- Lineal ordering is preserved among 'Just' nodes.
+ filterHomoMM :: HomoM r -> HomoM r
+--filterHomoMM :: Show r => HomoM r -> HomoM r
+ filterHomoMM x = x''
+ where
+#if 1
+ -- XXX oops, we don't even need the weights, done this way...
+ x' = condenseHomo defuzz x
+ -- Surely can do bottom-up and avoid iterating, but let's
+ -- get a correct output first!...
+ defuzz :: HomoM r -> HomoM r
+ defuzz (Node v chs) = Node v $ map defuzz chs'
+ where
+ chs' = filter g chs
+ g (Node Nothing []) = False
+ g _ = True
+ x'' = condenseHomo contractGlue x'
+-- x'' = trace ("FOO"++show x'++"BAR") $ contractGlue x'
+-- x'' = contractGlue x'
+ contractGlue :: HomoM r -> HomoM r
+ contractGlue (Node r chs) = Node r $ map contractGlue chs'
+ where
+ chs' = map contractNothing1 chs
+ contractNothing1 (Node Nothing [ch@(Node _ chs)]) = ch
+ contractNothing1 v = v
+#else
+ -- What is wanted here is standard zipping (in combining sense)
+ -- of rose trees, not generic ghom.
+ xw = f x
+ f (Node Nothing []) = Node (Nothing,0) []
+ f (Node (Just v) []) = Node (Just v,1) []
+ f (Node v chs) = Node (v,n) chs'
+ where
+ chs' = map f chs -- :: [ Homo (Maybe r, Int) ]
+ -- XXX where's our base case?!
+ n = sum $ map (\ (Node (_,m) _) -> m) chs'
+ x'' = defuzz xw
+ defuzz :: Homo (Maybe r, Int) -> Homo (Maybe r, Int)
+ defuzz (Node v chs) = Node v $ map defuzz chs'
+ where
+ chs' = filter g chs
+ g (Node (Nothing,_) []) = False
+ g _ = True
+-- You can't do this unless you want to require Data r:
+-- xw = ghomK (+) (\y->case y of { Nothing -> 0 ; Just _ -> 1 }) x
+#if 1
+ x''' = prune x'' -- :: HomoM r
+#else
+ x'' = zipRose x xw -- :: Homo (Maybe r, Int)
+ x''' = prune x'' -- :: HomoM r
+#endif
+ -- XXX This is wrong:
+ prune :: Homo (Maybe r, Int) -> HomoM r
+ prune (Node (v,0) _) = Node v []
+ prune (Node (v,_) chs) = Node v $ map prune chs
+ x'''' = trace ("FOO"++show x''++"BAZ"++show x'''++"BAR") $ contractGlue x'''
+ contractGlue :: HomoM r -> HomoM r
+ contractGlue (Node Nothing [R Nothing chs]) = Node Nothing $ map contractGlue chs
+ contractGlue (Node v chs) = Node v $ map contractGlue chs
+#endif
+
+ -- | As per 'filterHomoMM', but we string along the 'Dynamic' component.
+ filterBiMM :: BiM r -> BiM r
+--filterBiMM :: Show r => BiM r -> BiM r
+ filterBiMM x = x''
+ where
+ -- XXX oops, we don't even need the weights, done this way...
+ x' = condenseBi defuzz x
+ -- Surely can do bottom-up and avoid iterating, but let's
+ -- get a correct output first!...
+ defuzz :: BiM r -> BiM r
+ defuzz (Node v chs) = Node v $ map defuzz chs'
+ where
+ chs' = filter g chs
+ g (Node (_,Nothing) []) = False
+ g _ = True
+ x'' = condenseBi contractGlue x'
+-- x'' = trace ("FOO"++show x'++"BAR") $ contractGlue x'
+-- x'' = contractGlue x'
+ contractGlue :: BiM r -> BiM r
+ contractGlue (Node r chs) = Node r $ map contractGlue chs'
+ where
+ chs' = map contractNothing1 chs
+ contractNothing1 (Node (_,Nothing) [ch@(Node _ chs)]) = ch
+ contractNothing1 v = v
+
+-------------------------------------------------------------------------------
+
+ -- | Attempt to stop traversal on 'String's.
+ -- This should be in Shape.SYB, but it would be cyclical imports
+ -- which GHC can't handle.
+ -- XXX This seems not to be working.
+ -- The stop condition is not being done properly.
+ -- Refer to everythingBut (again) to remind how to do...
+ shapeOf_ :: forall d. Data d => d -> Shape
+ shapeOf_ x = unliftHomoM () $ filterHomoMM $ ghom fg x
+--shapeOf_ x = filterHomoM_' () $ ghom fg x
+ where
+ fg :: forall d'. Data d' => d' -> Maybe ()
+ fg = (const (Just ())) `extQ` f_String
+-- fg = (const (Just ())) `SYB.extQ` f_String `SYB.extQ` f_FastString
+--- fg = Just `SYB.extQ` f_String `SYB.extQ` f_FastString
+ f_String :: String -> Maybe ()
+ f_String x = Nothing
+-- f_FastString :: GHC.FastString -> Maybe ()
+-- f_FastString x = Nothing
+
+-------------------------------------------------------------------------------
+
diff --git a/src/SAI/Data/Generics/Shape/SYB/GHC.hs b/src/SAI/Data/Generics/Shape/SYB/GHC.hs
new file mode 100644
--- /dev/null
+++ b/src/SAI/Data/Generics/Shape/SYB/GHC.hs
@@ -0,0 +1,204 @@
+
+-------------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+
+-------------------------------------------------------------------------------
+
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : SAI.Data.Generics.Shape.SYB.GHC
+-- Copyright : (c) Andrew Seniuk, 2014
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : rasfar@gmail.com
+-- Stability : experimental
+-- Portability : non-portable (uses Data.Generics.Basics)
+--
+-- This package provides SYB shape support: generic fmap to
+-- homogeneous types, and related features. Complements existing
+-- Uniplate and TH shape libraries. See
+-- for more information.
+--
+-- The present module provides support for staged GHC AST types.
+-- One you have a @'Homo' r@, 'Hetero', or @'Bi' r@, the rest of
+-- the API in "Shape.SYB" and "Shape.SYB.Filter" is applicable.
+--
+-----------------------------------------------------------------------------
+
+ module SAI.Data.Generics.Shape.SYB.GHC (
+
+ -- * Staged shape functions
+
+ ghomStaged ,
+ ghomStagedK ,
+ ghomDynStaged ,
+ ghomBiStaged ,
+
+ GHC_AST_HOLE ,
+
+ shapeOfStaged ,
+ shapeOfStaged_ ,
+ sizeOfStaged ,
+
+ symmorphicStaged ,
+
+ weightedShapeOfStaged ,
+
+ -- * Re-exported from the ghc-syb-utils package
+
+ Stage(..) ,
+
+ ) where
+
+-------------------------------------------------------------------------------
+
+ import Data.Data ( gfoldl )
+ import Data.Data ( gmapQ )
+ import Data.Data ( Data )
+ import Data.Data ( Typeable )
+ import Data.Generics.Aliases ( GenericQ )
+
+#if USE_DATA_TREE
+ import SAI.Data.Generics.Shape.SYB ( Rose, Tree(Node) )
+#else
+ import SAI.Data.Generics.Shape.SYB ( Rose(..) )
+#endif
+ import SAI.Data.Generics.Shape.SYB ( Homo, Shape, Hetero, Bi )
+ import SAI.Data.Generics.Shape.SYB ( zipRose )
+
+ import SAI.Data.Generics.Shape.SYB.Filter ( filterHomoMM )
+--import SAI.Data.Generics.Shape.SYB.Filter ( filterHomoM_' )
+ import SAI.Data.Generics.Shape.SYB ( shapeOf )
+ import SAI.Data.Generics.Shape.SYB ( unliftHomoM )
+ import SAI.Data.Generics.Shape.SYB ( sizeOfRose )
+
+ import qualified GHC as GHC
+ import qualified NameSet as GHC
+ import qualified FastString as GHC
+
+ import qualified Data.Generics as SYB
+ import qualified GHC.SYB.Utils as SYB
+ import GHC.SYB.Utils ( Stage(..) )
+
+ import Data.Dynamic
+
+-------------------------------------------------------------------------------
+
+ newtype GHC_AST_HOLE = GHC_AST_HOLE Stage deriving ( Typeable )
+
+-------------------------------------------------------------------------------
+
+ ghomStaged :: forall r d. Data d =>
+ Stage
+ -> r
+ -> GenericQ r
+ -> d
+ -> Homo r
+ ghomStaged stage z f x
+ | checkItemStage stage x = z'
+ | otherwise = foldl k b (gmapQ (ghomStaged stage z f) x)
+ where
+ b = Node (f x) []
+ z' = Node z []
+ k (Node r chs) nod@(Node r' _) = Node r (chs++[nod])
+
+ ghomStagedK :: forall r d. Data d =>
+ Stage
+ -> r
+ -> (r -> r -> r)
+ -> GenericQ r
+ -> d
+ -> Homo r
+ ghomStagedK stage z k f x
+ | checkItemStage stage x = z'
+ | otherwise = foldl k' b (gmapQ (ghomStagedK stage z k f) x)
+ where
+ b = Node (f x) []
+ z' = Node z []
+ k' (Node r chs) nod@(Node r' _) = Node (r `k` r') (chs++[nod])
+
+ -- | Uses "Data.Dynamic" to support mutiple types homogeneously.
+ ghomDynStaged :: forall d. Data d => Stage -> d -> Hetero
+ ghomDynStaged stage x
+ | checkItemStage stage x = Node (toDyn $ GHC_AST_HOLE stage) []
+ | otherwise = foldl k b (gmapQ (ghomDynStaged stage) x)
+ where
+ b = Node (toDyn x) []
+ k (Node r chs) nod = Node r (chs++[nod])
+
+ -- | @'ghomBiStaged' s f x = 'zipRose' ('ghomDynStaged' s x) ('ghomStaged' s f x)@
+ ghomBiStaged :: forall r d. Data d => Stage -> r -> GenericQ r -> d -> Bi r
+ ghomBiStaged stage z f x = zipRose (ghomDynStaged stage x) $ ghomStaged stage z f x
+
+-------------------------------------------------------------------------------
+
+ shapeOfStaged :: forall d. Data d => Stage -> d -> Shape
+ shapeOfStaged stage = ghomStaged stage () (const ())
+
+ shapeOfStaged_ :: forall d. Data d => Stage -> d -> Shape
+ shapeOfStaged_ stage x = unliftHomoM () $ filterHomoMM $ ghomStaged stage Nothing fg x
+--shapeOfStaged_ stage x = filterHomoM_' () $ ghomStaged stage Nothing fg x
+ where
+ fg :: forall d'. Data d' => d' -> Maybe ()
+ fg = (const (Just ())) `SYB.extQ` f_String `SYB.extQ` f_FastString
+--- fg = Just `SYB.extQ` f_String `SYB.extQ` f_FastString
+ f_String :: String -> Maybe ()
+ f_String x = Nothing
+ f_FastString :: GHC.FastString -> Maybe ()
+ f_FastString x = Nothing
+
+ sizeOfStaged :: forall d. Data d => Stage -> d -> Int
+ sizeOfStaged stage = sizeOfRose . (shapeOfStaged stage)
+
+ weightedShapeOfStaged :: forall d. Data d => Stage -> d -> Homo Int
+ weightedShapeOfStaged stage = ghomStagedK stage 1 (+) (const 1)
+
+-------------------------------------------------------------------------------
+
+-- Borrowed from HaRe:
+
+-- From @frsoares
+
+--- | Checks whether the current item is undesirable for analysis in the current
+-- AST Stage.
+ checkItemStage :: (Typeable a, Data a) => Stage -> a -> Bool
+ checkItemStage stage x = (checkItemStage1 stage x)
+#if __GLASGOW_HASKELL__ > 704
+ || (checkItemStage2 stage x)
+#endif
+
+-- Check the Typeable items
+ checkItemStage1 :: (Typeable a) => Stage -> a -> Bool
+ checkItemStage1 stage x = (const False `SYB.extQ` postTcType `SYB.extQ` fixity `SYB.extQ` nameSet) x
+ where nameSet = const (stage `elem` [SYB.Parser,SYB.TypeChecker]) :: GHC.NameSet -> Bool
+ postTcType = const (stage < SYB.TypeChecker ) :: GHC.PostTcType -> Bool
+ fixity = const (stage < SYB.Renamer ) :: GHC.Fixity -> Bool
+
+#if __GLASGOW_HASKELL__ > 704
+--- | Check the Typeable1 items
+ checkItemStage2 :: Data a => Stage -> a -> Bool
+ checkItemStage2 stage x = (const False `SYB.ext1Q` hsWithBndrs) x
+ where
+ hsWithBndrs = const (stage < SYB.Renamer) :: GHC.HsWithBndrs a -> Bool
+#endif
+
+#if 0
+ checkItemRenamer :: (Data a, Typeable a) => a -> Bool
+ checkItemRenamer x = checkItemStage SYB.Renamer x
+#endif
+
+-------------------------------------------------------------------------------
+
+ -- | Compare two rose trees for shape equality.
+ symmorphicStaged :: forall d1 d2. (Data d1,Data d2) =>
+ Stage -> d1 -> d2 -> Bool
+ symmorphicStaged stage x y = shapeOfStaged stage x == shapeOfStaged stage y
+
+-------------------------------------------------------------------------------
+
diff --git a/tests/Main.hs b/tests/Main.hs
new file mode 100644
--- /dev/null
+++ b/tests/Main.hs
@@ -0,0 +1,46 @@
+
+{-# LANGUAGE CPP #-}
+
+ module Main where
+
+ import Test.HUnit
+ import System.Exit
+ import System.IO ( stdout )
+
+ import qualified ShapeSyb
+
+ import Debug.Trace ( trace )
+
+ tests =
+ "All" ~: [ ShapeSyb.tests
+ ]
+
+ main = do
+ putStrLn "Running tests for shape-syb..."
+#if 0
+#if 0
+ f :: String -> Bool -> () -> IO ()
+ f s b _ = putStrLn return ()
+#endif
+ (counts,_) <- runTestText (putTextToHandle stdout False) tests
+-- (counts,_) <- runTestText (putTextToHandle stdout False) ((tests!!0)!!0)
+-- (counts,_) <- runTestText (putTextToHandle stdout False) (tests!!0)
+#else
+ counts <- runTestTT tests
+#endif
+#if 0
+ log <- readFile "dist/test/sai-shape-syb-0.2.0-unit-tests.log"
+-- putStrLn log
+ if ( trace log ) $ failures counts > 0
+#endif
+ if failures counts > 0
+#if 1
+ then exitFailure
+ else exitSuccess
+#else
+ -- XXX Why is this saying "unexpected semicolons in source file"??
+ -- Template Haskell or something?...
+ then exitFailure
+ else exitSuccess
+#endif
+
diff --git a/tests/ShapeSyb.hs b/tests/ShapeSyb.hs
new file mode 100644
--- /dev/null
+++ b/tests/ShapeSyb.hs
@@ -0,0 +1,581 @@
+
+{-# LANGUAGE CPP #-}
+
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{- LANGUAGE NoMonomorphismRestriction #-}
+
+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
+
+-------------------------------------------------------------------------------
+
+ module ShapeSyb ( tests, main_tests ) where
+
+-------------------------------------------------------------------------------
+
+ import Test.HUnit
+
+ import SAI.Data.Generics.Shape
+
+ import Data.Data ( Data, Typeable )
+ import Data.Generics.Aliases ( mkQ, extQ )
+ import Data.Generics.Aliases ( GenericQ )
+ import Data.List ( intersperse )
+ import Control.Exception ( evaluate )
+--import Data.Dynamic
+
+ -- Testing abstract datatype:
+ import qualified Data.Map as Map
+ import Data.Map ( Map )
+
+--import Debug.Trace ( trace )
+
+ import Control.Monad
+ import Data.Maybe
+
+ import System.IO.Unsafe ( unsafePerformIO )
+
+-------------------------------------------------------------------------------
+
+ -- Sample types and values (constructor application expressions).
+ -- Expected structures are shown in parentheses language.
+
+ test_list = [[1,2],[3],[4,5,6::Int]]
+
+ data TA = A1 | A2 TB TA TB
+ data TB = B TA
+
+ exprAB = A2 (B A1) A1 (B A1)
+ -- ((())()(()))
+
+ data TC = C1 Float (Int,Int) | C2 TD TC TD | C3 TC
+ data TD = D TC
+
+ exprCD = C2 (D (C1 1.1 (4,5))) (C3 (C1 2.2 (6,7))) (D (C1 3.3 (8,9)))
+ -- (((()(()())))((()(()())))((()(()())))
+
+ data TE = E1 String | E2 (Int,Int) TF
+ data TF = F TE String
+
+ exprEF = E2 (2,5) (F (E1 "foo") "bar")
+ -- ((()(())())()())
+
+ -- For testing that Dynamic can recover nodes elided below a node.
+ data TG = G TH
+ data TH = H TI
+ data TI = I
+ data TJ = J | J1 TJ | J2 TJ | J3 TJ
+ exprGHI = G (H I) -- multiple types
+ exprJ = J1 (J2 (J3 J)) -- multiple data constructors
+
+ data TK = K1 TL | K2 TM | K3
+ data TL = L1 | L2 TL | L3 TM
+ data TM = M1 TL TL | M2 TK
+ exprKLM = K2 (M1 (L2 L1) (L2 (L3 (M2 K3))))
+
+ exprN = Map.fromList [("sfv",2.2),("pdsfhp",3.3),("",1.1)] :: Map String Float
+
+ -- requires -XStandaloneDeriving (this isn't really what it's for...)
+ deriving instance Data TA ; deriving instance Typeable TA
+ deriving instance Data TB ; deriving instance Typeable TB
+ deriving instance Data TC ; deriving instance Typeable TC
+ deriving instance Data TD ; deriving instance Typeable TD
+ deriving instance Data TE ; deriving instance Typeable TE
+ deriving instance Data TF ; deriving instance Typeable TF
+ deriving instance Data TG ; deriving instance Typeable TG
+ deriving instance Data TH ; deriving instance Typeable TH
+ deriving instance Data TI ; deriving instance Typeable TI
+ deriving instance Data TJ ; deriving instance Typeable TJ
+ deriving instance Data TK ; deriving instance Typeable TK
+ deriving instance Data TL ; deriving instance Typeable TL
+ deriving instance Data TM ; deriving instance Typeable TM
+
+ -- often you would not have any Show instance for your
+ -- source types, but here it's useful for preparing
+ -- my writeup...
+ deriving instance Show TA
+ deriving instance Show TB
+ deriving instance Show TC
+ deriving instance Show TD
+ deriving instance Show TE
+ deriving instance Show TF
+ deriving instance Show TG
+ deriving instance Show TH
+ deriving instance Show TI
+ deriving instance Show TJ
+ deriving instance Show TK
+ deriving instance Show TL
+ deriving instance Show TM
+
+-------------------------------------------------------------------------------
+
+ -- Target type for some of the homomorphisms exercised.
+
+ -- Typeable for Hetero/Bi which use Data.Dynamic.
+ -- Eq used to be needed for filterHomo etc. but not anymore.
+ data Result = Result (Int,Int) deriving ( Show, Typeable )
+
+ -- A lifted type (Result (Maybe (Int,Int)) would be better)!
+ dud_result = Result (0,0)
+
+ pair_result pair = Result pair
+
+-------------------------------------------------------------------------------
+
+ test0 :: TC -> Homo Result
+ test0 = ghom (mkQ dud_result f)
+--test0 = ghom (\r _->r) (mkQ dud_result f)
+ where
+ -- This is only generic in the sense that other types
+ -- will still be traversed (passed over).
+-- f :: TC -> Result
+ f (C1 _ pair) = pair_result pair
+ f (C2 _ _ d2@(D c)) = let g (Result (x,y)) = Result (y,x) in g (f c)
+-- f (C2 _ _ d2@(D c)) = f c -- line above is more interesting
+ f x = dud_result -- still needed! (notwithstanding mkQ)
+-- f x = x
+
+#if 0
+
+--test1 :: TC -> Homo Result
+--test1 = ghomP (mkQ True p) (\r _->r) (mkQ dud_result f)
+ test1 = ghomP p' (\r _->r) (mkQ dud_result f)
+ where
+
+ f :: TC -> Result -- correct (but unneeded)
+--- f :: forall b. Data b => b -> Result -- wrong (we'd like it though)
+ f (C1 _ pair) = pair_result pair
+ f (C2 _ _ d2@(D c)) = let g (Result (x,y)) = Result (y,x) in g (f c)
+-- f (C2 _ _ d2@(D c)) = f c -- line above is more interesting
+ f x = dud_result
+
+ p :: TC -> Bool -- correct (but unneeded)
+--- p :: forall e. (Data e, Typeable e) => e -> Bool -- (would be nice)
+ p (C1 _ (i1,i2)) = i1 < 7
+-- p (C1 _ (i1,i2)) = i1 < i2
+-- p (C2 _ _ d2@(D c)) = p c
+ p x = True
+ -- one or the other sig. is NEEDED:
+-- p' :: forall d. (Data d, Typeable d) => d -> Bool
+ p' :: GenericQ Bool
+-- p' = mkQ True (\x -> p (x :: (forall d. (Data d, Typeable d) => d)))
+-- p' = mkQ True (\x -> p (x :: (forall d. (Data d) => d)))
+ p' = mkQ True p
+--mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
+--type GenericQ r = forall a. Data a => a -> r
+--data TC = C1 Float (Int,Int) | C2 TD TC TD deriving ( Data, Typeable )
+--data TD = D TC deriving ( Data, Typeable )
+
+#else
+
+ -- It is necessary to have SOME boilerplate in the user code,
+ -- like "mkQ", because the type system won't let me pass a
+ -- generically-typed function f to by mkQ'd in callee?
+ -- It's tempting to just go with k = (\r _->r) internally,
+ -- were it not for the early precedent of weightedShapeOf...
+ -- Still, mapping a ()-tree to an Int-tree bearing branch
+ -- weights is not really in the purview of this mini-project,
+ -- so, yeah, I'm getting rid of that!... Yay!
+ -----------
+ -- Later: needed to make f as a whole return Maybe r...
+ test1 :: TC -> [Homo Result]
+ test1 = gfilter (mkQP p f)
+ where
+#if 1
+ p :: Result -> Bool
+ p (Result (x,_)) = x < 7
+ p x = False
+#else
+ p :: TC -> Bool
+ p (C1 _ (i1,i2)) = i1 < 7
+ p x = True
+#endif
+ f :: TC -> Maybe Result
+-- f :: TC -> Result
+ f (C1 _ pair)
+ = Just $ pair_result pair
+ f (C2 _ _ d2@(D c))
+ = let g (Just (Result (x,y))) = Just (Result (y,x)) in g (f c)
+ f x = Nothing
+-- f x = dud_result
+
+#endif
+
+ test1b :: TC -> Homo Result
+ test1b = gfilter_ dud_result (mkQP p f)
+ where
+#if 1
+ p :: Result -> Bool
+ p (Result (x,_)) = x < 7
+ p x = False
+#else
+ p :: TC -> Bool
+ p (C1 _ (i1,i2)) = i1 < 7
+ p x = True
+#endif
+ f :: TC -> Maybe Result
+-- f :: TC -> Result
+ f (C1 _ pair)
+ = Just $ pair_result pair
+ f (C2 _ _ d2@(D c))
+ = let g (Just (Result (x,y))) = Just (Result (y,x)) in g (f c)
+ f x = Nothing
+-- f x = dud_result
+#if 0
+ test1' :: TC -> Homo Result
+ test1' = ghomP' p (mkQ dud_result f)
+ where
+-- f :: forall d. Data d => d -> Result
+ f (C1 _ pair) = pair_result pair
+ f (C2 _ _ d2@(D c)) = let g (Result (x,y)) = Result (y,x) in g (f c)
+-- f (C2 _ _ d2@(D c)) = f c -- line above is more interesting
+ f x = dud_result
+-- f x = x
+-- p :: Homo Result -> Bool
+-- p (R (Result (x,y)) _) = not $ x == 0 && y == 0
+ p :: Result -> Bool
+ p (Result (x,y)) = not $ x == 0 && y == 0
+#endif
+
+ test2 :: TC -> Homo Result
+ test2 = ghom ((const dud_result) `extQ` fTC `extQ` fTD)
+ where
+
+ fTC :: TC -> Result
+ fTC (C1 _ pair) = pair_result pair
+ -- Note we don't need to cover all the cases, or provide a base case;
+ -- SYB provides the default case for us automatically.
+ fTC x = dud_result
+-- fTC x = x
+
+ fTD :: TD -> Result
+ fTD (D c) = Result (1,1)
+-- fTD (D c) = (mkQ (const dud_result) fTC) c -- why not?
+-- fTD (D c) = fTC c -- risk non-exhaustive patterns runtime errpr
+ fTD x = dud_result
+-- fTD x = x
+
+---------------------------------------
+
+ data CompanyType = Company [DepartmentType]
+ data DepartmentType = Department String ManagerType [EmployeeType]
+ data ManagerType = Manager { rank :: Float
+ , manName :: String
+ , manSalary :: SalaryType }
+ data EmployeeType = Employee { empName :: String
+ , empSalary :: SalaryType }
+ data SalaryType = Salary Float
+
+ deriving instance Data CompanyType ; deriving instance Typeable CompanyType
+ deriving instance Data DepartmentType ; deriving instance Typeable DepartmentType
+ deriving instance Data ManagerType ; deriving instance Typeable ManagerType
+ deriving instance Data EmployeeType ; deriving instance Typeable EmployeeType
+ deriving instance Data SalaryType ; deriving instance Typeable SalaryType
+
+ deriving instance Show CompanyType
+ deriving instance Show DepartmentType
+ deriving instance Show ManagerType
+ deriving instance Show EmployeeType
+ deriving instance Show SalaryType
+
+ data NiceRecord = NiceHole
+ | NiceRecord { nice_name :: String
+ , nice_salary :: Int }
+ deriving ( Show )
+
+ isNiceHole NiceHole = True
+ isNiceHole _ = False
+
+------------------------------
+
+ -- small, one department retail company
+ company1 = Company [Department "Sales" (Manager 1 "Deborah" (Salary 75000)) [Employee "Jane" (Salary 35000)]]
+
+--test4 :: EmployeeType -> Homo NiceRecord
+--test4 :: forall d. Data d => d -> Homo NiceRecord
+ test4 = ghom (const NiceHole `extQ` f_EmployeeType `extQ` f_ManagerType)
+--test4 = ghom f
+ where
+ -- No sum types involved, so no explicit defaults
+ -- needed (unlike in previous examples).
+ f_EmployeeType (Employee name (Salary salary))
+ = NiceRecord name (floor salary)
+ f_ManagerType (Manager _ name _)
+ = NiceRecord name 0
+
+ test5 :: [[Int]] -> [[Maybe Bool]]
+ test5 = map (map (\x ->if odd x then Just True else Nothing))
+
+-----------------------------------
+
+#if 1
+ -- XXX This is now a hack; I'm only trying to make my
+ -- executable "test-sai-shape-syb" (test-05.hs) instead
+ -- work as unit-tests in cabal; the sole reason being,
+ -- to prevent building it every rebuild, as building
+ -- this and linking it takes like 20 seconds!...
+ main_tests :: IO Int
+ main_tests = do
+#if 1
+ -- When developing SYB code, it can matter whether or
+ -- not your functions are used -- if they're not demanded,
+ -- you may get (compile-time) type errors requiring explicit
+ -- type signatures. This can be prevented by creating
+ -- artificial demand thus:
+ evaluate (test4 company1)
+#endif
+ putStrLn $ concat $ intersperse "\n" [ ""
+
+ , "> show test_list\n "
+ , show test_list ++ "\n"
+ , "> showHomo $ shapeOf test_list\n "
+ , showHomo $ shapeOf test_list
+ , "> showAsParens $ shapeOf test_list\n "
+ , (showAsParens $ shapeOf test_list) ++ "\n"
+ , "> showAsParensBool $ ghom (mkQ False (odd::Int->Bool)) test_list\n "
+ , (showAsParensBool $ ghom (mkQ False (odd::Int->Bool)) test_list) ++ "\n"
+ , "> showAsParensEnriched $ ghom (mkQ False (odd::Int->Bool)) test_list\n "
+ , (showAsParensEnriched $ ghom (mkQ False (odd::Int->Bool)) test_list) ++ "\n"
+ , "> showHomo $ ghom (mkQ False (odd::Int->Bool)) test_list\n "
+ , showHomo $ ghom (mkQ False (odd::Int->Bool)) test_list
+ , "> showHomo $ filterHomo id $ ghom (mkQ False (odd::Int->Bool)) test_list\n "
+ , showHomo $ filterHomo id $ ghom (mkQ False (odd::Int->Bool)) test_list
+ , "> showHetero $ ghomDyn test_list\n "
+ , showHetero $ ghomDyn test_list
+ , "> showHetero $ filterHetero (/=(3::Int)) $ ghomDyn test_list\n "
+ , showHetero $ filterHetero (/=(3::Int)) $ ghomDyn test_list
+ , "> showBi $ heteroToBi False (odd::Int->Bool) $ ghomDyn test_list\n "
+ , showBi $ heteroToBi False (odd::Int->Bool) $ ghomDyn test_list
+
+#if 1
+
+#if 0
+ , "> showHomo $ heteroToHomo $ filterHetero (/=3::Int) $ ghomDyn test_list\n "
+ , showHomo $ heteroToHomo $ filterHetero (/=3::Int) $ ghomDyn test_list
+#endif
+ , "> showBi $ ghomBi (mkQ False (odd::Int->Bool)) test_list\n "
+ , showBi $ ghomBi (mkQ False (odd::Int->Bool)) test_list
+ , "> showBi $ filterBi id $ ghomBi (mkQ False (odd::Int->Bool)) test_list\n "
+ , showBi $ filterBi id $ ghomBi (mkQ False (odd::Int->Bool)) test_list
+ , "> showHomo $ biToHomo $ filterBi id $ ghomBi (mkQ False (odd::Int->Bool)) test_list\n "
+ , showHomo $ biToHomo $ filterBi id $ ghomBi (mkQ False (odd::Int->Bool)) test_list
+ , "> let f (x::Int) = if odd x then Just x else Nothing\n"
+ , "> showHomo $ ghom (mkQ Nothing f) test_list\n "
+ , showHomo $ ghom (mkQ Nothing (\x -> if odd (x::Int) then Just x else Nothing)) test_list
+ , "> showHomo $ filterHomoMM $ ghom (mkQ Nothing f) test_list\n "
+ , showHomo $ filterHomoMM $ ghom (mkQ Nothing (\x -> if odd (x::Int) then Just x else Nothing)) test_list
+ , "> showHomo $ unliftHomoM 0 $ filterHomoMM $ ghom (mkQ Nothing f) test_list\n "
+ , showHomo $ unliftHomoM 0 $ filterHomoMM $ ghom (mkQ Nothing (\x -> if odd (x::Int) then Just x else Nothing)) test_list
+
+#endif
+
+#if 1
+ , "> showAsParens $ shapeOf exprAB\n "
+ , (showAsParens $ shapeOf exprAB) ++ "\n"
+ , "> showAsParens $ shapeOf exprCD\n "
+ , (showAsParens $ shapeOf exprCD) ++ "\n"
+ , "> showAsParens $ shapeOf exprEF\n "
+ , (showAsParens $ shapeOf exprEF) ++ "\n"
+#endif
+
+ , "> show $ ( ( unGhomDyn $ ghomDyn exprEF ) :: TE )\n "
+ , (show $ ( ( unGhomDyn $ ghomDyn exprEF ) :: TE ) ) ++ "\n"
+
+ , "> showHomo $ ( gempty exprEF :: BiM Int)\n "
+ , (showHomo $ ( gempty exprEF :: BiM Int)) ++ "\n"
+
+ , "Progressive refinement and accumulation:\n"
+#if 1
+ , "\
+> (showHomo $\n\
+ ( grefine\n\
+ (\\ x -> case x of { E2 (y,z) _ -> Just (z+3)\n\
+ ; _ -> Nothing })\n\
+ ( gempty exprEF :: BiM Int)\n\
+ )\n\
+ )\n"
+#endif
+ , (showHomo $
+ ( grefine
+ (\ x -> case x of { E2 (y,z) _ -> Just (z+3)
+ ; _ -> Nothing })
+ ( gempty exprEF :: BiM Int)
+ )
+ )
+-- , (showHomo $ ( grefine (\ x -> case x of { (E2 (y,z) _) -> Just (z+3) ; _ -> Nothing }) ( gempty exprEF :: BiM Int))) ++ "\n"
+-- , (showHomo $ ( grefine (\ x -> case x of { (E2 (y,z) _) -> z+3 ; _ -> -1 }) ( gempty exprEF :: BiM Int))) ++ "\n" -- works, but...
+-- , (showHomo $ ( grefine (\ x -> case x of { (E2 (y,z) _) -> z+3 ; _ -> undefined::Int }) ( gempty exprEF :: BiM Int))) ++ "\n"
+-- , (showHomo $ ( grefine (\ (E2 (x,y) _) -> y+3) ( gempty exprEF :: BiM Int))) ++ "\n"
+#if 0
+-- This is giving me Just 3 at every node (whether source node was TE or TF):
+ , "> showHomo $ ( grefine (\\x -> 3) ( gempty exprEF :: BiM Int))\n "
+ , (showHomo $ ( grefine (\(x::TF) -> 3) ( gempty exprEF :: BiM Int))) ++ "\n"
+#endif
+
+-- XXX Still can't figure it out...
+#if 0
+ , (showHomo $ ( grefineG (mkQ Nothing ((\ x -> case x of { (E2 (y,z) _) -> Just (z+3) ; _ -> Nothing }) :: TE -> Maybe Int)) ( gempty exprEF :: BiM Int))) ++ "\n"
+-- , (showHomo $ ( grefineG (mkQ Nothing ((\ x -> case x of { (E2 (y,z) _) -> Just (z+3) ; _ -> Nothing }) :: TE -> Maybe Int)) ( gempty exprEF :: BiM Int))) ++ "\n"
+#endif
+
+#if 0
+ , "blah\
+\foo"
+#endif
+#if 0
+ , "foo\
+\ bar"
+#endif
+#if 0
+ , "foo\
+ , (showHomo $\
+ ( gaccum\
+ ((\\r1 r2 -> r1+r2) :: Int -> Int -> Int)"
+#endif
+#if 1
+ , "\
+> (showHomo $\n\
+ ( gaccum\n\
+ ((\\r1 r2 -> r1+r2) :: Int -> Int -> Int)\n\
+ (\\ x -> case x of { E1 s -> Just (length s)\n\
+ ; _ -> Nothing })\n\
+ ( grefine\n\
+ (\\ x -> case x of { E2 (y,z) _ -> Just (z+3)\n\
+ ; _ -> Nothing })\n\
+ ( gempty exprEF :: BiM Int)\n\
+ )\n\
+ )\n\
+ )\n"
+#endif
+ , (showHomo $
+ ( gaccum
+ ((\r1 r2 -> r1+r2) :: Int -> Int -> Int)
+ (\ x -> case x of { E1 s -> Just (length s)
+ ; _ -> Nothing })
+ ( grefine
+ (\ x -> case x of { E2 (y,z) _ -> Just (z+3)
+ ; _ -> Nothing })
+ ( gempty exprEF :: BiM Int)
+ )
+ )
+ )
+
+ , "\nTesting that a Dynamic node can recover nodes elided below it:\n"
+ , "Testing a chain of types:\n"
+ , "> let (f::TH->Bool) x = case x of { H _ -> False ; _ -> True }\n"
+ , "> show exprGHI\n"
+ , show exprGHI ++ "\n"
+ , "> showBi $ ghomBi (mkQ True f) exprGHI\n"
+ , showBi $ ghomBi (mkQ True ( (\ x -> case x of { H _ -> False ; _ -> True }) :: TH -> Bool ) ) exprGHI
+ , "> showBi $ filterBi id $ ghomBi (mkQ True f) exprGHI\n"
+ , showBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { H _ -> False ; _ -> True }) :: TH -> Bool ) ) exprGHI
+ , "> ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True f) exprGHI ) :: TG ) )\n"
+ , ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { H _ -> False ; _ -> True }) :: TH -> Bool ) ) exprGHI ) :: TG ) ) ++ "\n"
+
+ , "Testing a chain of constructors:\n"
+ , "> show exprJ\n"
+ , show exprJ ++ "\n"
+ , "> let (f::TJ->Bool) x = case x of { J1 _ -> False ; J3 _ -> False; _ -> True }\n"
+ , "> showBi $ ghomBi (mkQ True f) exprJ\n"
+ , showBi $ ghomBi (mkQ True ( (\ x -> case x of { J1 _ -> False ; J3 _ -> False; _ -> True }) :: TJ -> Bool ) ) exprJ
+ , "> showBi $ filterBi id $ ghomBi (mkQ True f) exprJ\n"
+ , showBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { J1 _ -> False ; J3 _ -> False; _ -> True }) :: TJ -> Bool ) ) exprJ
+ , "> ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True f) exprJ ) :: TJ ) )\n"
+ , ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { J1 _ -> False ; J3 _ -> False; _ -> True }) :: TJ -> Bool ) ) exprJ ) :: TJ ) ) ++ "\n"
+
+ , "Testing a mixture of types and constructors:\n"
+ , "> show exprKLM\n"
+ , show exprKLM ++ "\n"
+ , "> let (f::TL->Bool) x = case x of { L2 _ -> False ; L3 _ -> False; _ -> True }\n"
+ , "> showBi $ ghomBi (mkQ True f) exprKLM\n"
+ , showBi $ ghomBi (mkQ True ( (\ x -> case x of { L2 _ -> False ; L3 _ -> False; _ -> True }) :: TL -> Bool ) ) exprKLM
+ , "> showBi $ filterBi id $ ghomBi (mkQ True f) exprKLM\n"
+ , showBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { L2 _ -> False ; L3 _ -> False; _ -> True }) :: TL -> Bool ) ) exprKLM
+ , "> ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True f) exprKLM ) :: TK ) )\n"
+ , ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { L2 _ -> False ; L3 _ -> False; _ -> True }) :: TL -> Bool ) ) exprKLM ) :: TK ) ) ++ "\n"
+
+ , "\nTesting filterHomoM and filterBiM:\n"
+ , "> show test_list\n"
+ , show test_list ++ "\n"
+ , "> showHomo $ filterHomoM odd $ ghom (mkQ 0 (id::Int->Int)) test_list\n"
+ , showHomo $ filterHomoM odd $ ghom (mkQ 0 (id::Int->Int)) test_list
+ , "> showBi $ filterBiM odd $ ghomBi (mkQ 0 (id::Int->Int)) test_list\n"
+ , showBi $ filterBiM odd $ ghomBi (mkQ 0 (id::Int->Int)) test_list
+-- , showBi $ filterBiM odd $ ghomBi (mkQ (-1) (id::Int->Int)) test_list
+
+ -- is WORKING!...
+ , "\nTesting abstract datatype:\n"
+ , "> show exprN\n"
+ , show exprN ++ "\n"
+ , "> show $ Map.toList exprN\n"
+ , (show $ Map.toList exprN) ++ "\n"
+ , "> showHomo $ shapeOf exprN\n"
+ , showHomo $ shapeOf exprN
+ , "> showAsParensEnriched $ shapeOf exprN\n"
+ , (showAsParensEnriched $ shapeOf exprN) ++ "\n"
+ , "> showHomo $ ghom (mkQ 0.0 (\\ (x::Float) -> x)) exprN\n"
+ , showHomo $ ghom (mkQ 0.0 (\ (x::Float) -> x)) exprN
+ , "> showHomo $ filterHomo (>0.5) $ ghom (mkQ 0.0 (\\ (x::Float) -> x)) exprN\n"
+ , showHomo $ filterHomo (>0.5) $ ghom (mkQ 0.0 (\ (x::Float) -> x)) exprN
+ , "> showHomo $ filterHomoM (>0.5) $ ghom (mkQ 0.0 (\\ (x::Float) -> x)) exprN\n"
+ , showHomo $ filterHomoM (>0.5) $ ghom (mkQ 0.0 (\ (x::Float) -> x)) exprN
+
+#if 0
+
+ , "show exprCD\n "
+ , show exprCD ++ "\n"
+ , "showHomo $ shapeOf exprCD\n "
+ , showHomo $ shapeOf exprCD
+ , "showAsParens $ shapeOf exprCD\n "
+ , (showAsParens $ shapeOf exprCD) ++ "\n"
+ , "showHomo $ test0 exprCD\n "
+ , showHomo $ test0 exprCD
+ , "concatMap showHomo $ test1 exprCD -- gfilter\n "
+ , (concatMap showHomo $ test1 exprCD) ++ "\n"
+ , "showHomo $ test1b exprCD -- gfilter_\n "
+ , showHomo $ test1b exprCD
+ , "showHomo $ test2 exprCD\n "
+ , showHomo $ test2 exprCD
+ , "showHomo $ filterHomo (\\ (Result (x,y)) -> not $ x == 0 && y == 0 ) $ test2 exprCD\n "
+ , showHomo $ filterHomo (\ (Result (x,y)) -> not $ x == 0 && y == 0 ) $ test2 exprCD
+
+ , "showHomo $ shapeOf exprEF\n "
+ , showHomo $ shapeOf exprEF
+
+ , "show company1\n "
+ , show company1 ++ "\n"
+ , "showAsParens $ shapeOf company1\n "
+ , (showAsParens $ shapeOf company1) ++ "\n"
+ , "showHomo $ shapeOf company1\n "
+ , showHomo $ shapeOf company1
+ , "showHomo $ test4 company1\n "
+ , showHomo $ test4 company1
+ , "showHomo $ filterHomo (not . isNiceHole) $ test4 company1\n "
+ , showHomo $ filterHomo (not . isNiceHole) $ test4 company1
+-- , showHomo $ filterHomo (not . isNiceHole) $ shapeOf exprAB -- pointless
+
+#endif
+
+ ]
+#endif
+ return 0
+
+-------------------------------------------------------------------------------
+
+-- XXX A better way to "fail on purpose" is to have the test
+-- return ExitFailure, no?...
+--tests = (unsafePerformIO main_tests == output) ~? "FAILING ON PURPOSE TO DISPLAY THE LOGGED OUTPUT!" -- yeah but it wasn't printed
+ tests = unsafePerformIO
+ ( do n <- main_tests
+ putStrLn "FAILING ON PURPOSE TO DISPLAY THE LOGGED OUTPUT!\n"
+ return n )
+ ~=? output
+ output = 1::Int -- force test to fail! (so we see the output!)
+--output = 0::Int
+--output = ()
+
+-------------------------------------------------------------------------------
+
diff --git a/tests/test-01.hs b/tests/test-01.hs
new file mode 100644
--- /dev/null
+++ b/tests/test-01.hs
@@ -0,0 +1,49 @@
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+ module Main ( main ) where
+
+ import SAI.Data.Generics.Shape.SYB ( Homo, ghom, shapeOf, weightedShapeOf )
+--import SAI.Data.Generics.Shape.SYB ( Rose(..) )
+ import Data.Data ( Data, Typeable )
+--import Data.Data
+ import Data.Generics.Aliases ( mkT )
+ import Data.Generics.Schemes ( everywhere )
+--import Data.Generics ( Generic )
+--import Data.Tree ( Tree(..) )
+
+#if 1
+ data TA = A1 | A2 TB TA TB deriving ( Data, Typeable )
+ data TB = B TA deriving ( Data, Typeable )
+ exprAB = A2 (B A1) A1 (B A1)
+#else
+ data TA = A1 | A2 TB deriving ( Data, Typeable )
+ data TB = B TA deriving ( Data, Typeable )
+ exprAB = A2 (B (A2 (B A1)))
+ data TA = A1 String | A2 (Int,Int) TB deriving ( Data, Typeable )
+--instance Data TA
+--instance Typeable TA
+--instance Generic TA
+ data TB = B TA String deriving ( Data, Typeable )
+--instance Data TB
+--instance Typeable TB
+--instance Generic TB
+--data TA = A1 String | A2 (Int,Int) TB deriving ( Data, Typeable )
+--data TB = B TA String deriving ( Data, Typeable )
+ exprAB = A2 (2,5) (B (A1 "foo") "bar")
+#endif
+
+ main = putStrLn $ show $ shapeOf exprAB
+--main = putStrLn $ show $ ( mkDataTree $ shapeOf exprAB :: Tree () )
+--main = putStrLn $ show $ ( shapeOf exprAB :: Tree () )
+--main = putStrLn $ show $ shapeOf ( exprAB :: TA )
+--main = putStrLn $ show $ wtdShapeOf ( exprAB :: TA )
+--main = putStrLn $ show $ wtdShapeOf ( [[1,2],[3],[4,5,6]] :: [[Int]] )
+--main = putStrLn $ show $ wtdShapeOf [[1,2],[3],[4,5,6]]
+
+ wtdShapeOf :: forall d. Data d => d -> Homo Int
+ wtdShapeOf = ghom (const 1) (+) -- as of typing this line, battery died!
+
diff --git a/tests/test-02.hs b/tests/test-02.hs
new file mode 100644
--- /dev/null
+++ b/tests/test-02.hs
@@ -0,0 +1,72 @@
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+-- has to have separate line for Data and Typeable, so not worth it here;
+-- can be useful for supplying instances for datatypes in other modules.
+{- LANGUAGE StandaloneDeriving #-}
+
+ module Main ( main ) where
+
+ import SAI.Data.Generics.Shape.SYB ( Homo, ghom, shapeOf, weightedShapeOf )
+ import Data.Data ( Data, Typeable )
+--import Data.Generics.Aliases ( mkT )
+--import Data.Generics.Schemes ( everywhere )
+ import Data.Generics.Aliases ( mkQ )
+ import Data.Generics.Aliases ( extQ )
+
+#if 0
+ data TC = C1 Float (Int,Int) | C2 TD TC TD deriving ( Data, Typeable )
+--data TC = C1 Float (Int,Int) | C2 TD TC TD
+ data TD = D TC
+ deriving instance Data TD
+ deriving instance Typeable TD
+--deriving instance ( Data, Typeable ) TD
+#else
+ data TC = C1 Float (Int,Int) | C2 TD TC TD deriving ( Data, Typeable )
+ data TD = D TC deriving ( Data, Typeable )
+#endif
+ exprCD = C2 (D (C1 1.0 (1,2))) (C1 3.0 (3,4)) (D (C1 5.0 (5,6)))
+
+--data Result = Result (Int,Int) deriving ( Show, Data, Typeable )
+ data Result = Result (Int,Int) deriving ( Show )
+ dud_result = Result (0,0)
+ pair_result pair = Result pair
+
+ main = putStrLn $ show $ test2 exprCD
+--main = putStrLn $ show $ test1 exprCD
+
+ -- XXX What is needed is mkQ (and perhaps extQ).
+ -- This makes a generic query out of a type-specific one.
+ -- (Recall that a "query" is a function from d -> r,
+ -- where d is generic (forall d. Data d =>).)
+
+ test1 :: TC -> Homo Result
+ test1 = ghom (mkQ dud_result f) (\r _->r)
+--test1 = ghom (mkQ (const dud_result) f) (\r _->r)
+ where
+ -- This is only generic in the sense that you don't
+ -- need to match all ctors?...
+-- f :: forall d. Data d => d -> Result
+ f (C1 _ pair) = pair_result pair
+ f (C2 _ _ d2@(D c)) = f c
+ f x = dud_result
+
+--test2 :: TC -> Homo Result
+ test2 = ghom ((const dud_result) `extQ` fTC `extQ` fTD) (\r _->r)
+--test2 = ghom ((const dud_result) `extQ` (mkQ dud_result fTC) `extQ` (mkQ dud_result fTD)) (\r _->r)
+--test2 = ghom ((mkQ dud_result fTC) `extQ` (mkQ dud_result fTD)) (\r _->r)
+ where
+ fTC :: TC -> Result
+ fTC (C1 _ pair) = pair_result pair
+-- fTC (C2 _ _ d2@(D c)) = fTC c
+ fTC x = dud_result
+ fTD :: TD -> Result
+ fTD (D c) = fTC c
+ fTD x = dud_result
+
+ wtdShapeOf :: forall d. Data d => d -> Homo Int
+ wtdShapeOf = ghom (const 1) (+) -- as of typing this line, battery died!
+
diff --git a/tests/test-03.hs b/tests/test-03.hs
new file mode 100644
--- /dev/null
+++ b/tests/test-03.hs
@@ -0,0 +1,71 @@
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+ module Main ( main ) where
+
+ import SAI.Data.Generics.Shape.SYB ( Homo, ghom, shapeOf, weightedShapeOf )
+--import SAI.Data.Generics.Shape.SYB ( Rose(..) )
+ import SAI.Data.Generics.Shape.SYB ( showAsParens )
+ import Data.Data ( Data, Typeable )
+--import Data.Data
+ import Data.Generics.Aliases ( extQ )
+--import Data.Generics.Aliases ( mkT )
+--import Data.Generics.Schemes ( everywhere )
+--import Data.Generics ( Generic )
+--import Data.Tree ( Tree(..) )
+
+ data CompanyType = Company [DepartmentType]
+ data DepartmentType = Department String ManagerType [EmployeeType]
+ data ManagerType = Manager { rank :: Float
+ , manName :: String
+ , manSalary :: SalaryType }
+ data EmployeeType = Employee { empName :: String
+ , empSalary :: SalaryType }
+ data SalaryType = Salary Float
+ deriving instance Data CompanyType
+ deriving instance Data DepartmentType
+ deriving instance Data ManagerType
+ deriving instance Data EmployeeType
+ deriving instance Data SalaryType
+ deriving instance Typeable CompanyType
+ deriving instance Typeable DepartmentType
+ deriving instance Typeable ManagerType
+ deriving instance Typeable EmployeeType
+ deriving instance Typeable SalaryType
+
+ data NiceRecord = NiceRecord { nice_name :: String
+ , nice_salary :: Int }
+ deriving ( Show )
+ dud_record = NiceRecord "" 0
+
+------------------------------
+
+ -- small, one department retail company
+ company1 = Company [Department "Sales" (Manager 1 "Deborah" (Salary 75000)) [Employee "Jane" (Salary 35000)]]
+
+ main = putStrLn $ showAsParens $ shapeOf company1
+--main = putStrLn $ show $ shapeOf company1
+--main = putStrLn $ show $ test1 company1
+--main = putStrLn $ show $ test2 company1
+
+ test1 :: CompanyType -> Homo ()
+--test1 :: forall d. Data d => d -> Homo ()
+ test1 = ghom (\_ _->()) (const ())
+
+#if 0
+--test2 :: EmployeeType -> Homo NiceRecord
+--test2 :: forall d. Data d => d -> Homo NiceRecord
+ test2 = ghom k (const dud_record `extQ` f_EmployeeType `extQ` f_ManagerType)
+--test2 = ghom k f
+ where
+ f_EmployeeType (Employee name (Salary salary))
+ = NiceRecord name (floor salary)
+ f_ManagerType (Manager _ name _)
+ = NiceRecord name 0
+ k r _ = r
+#endif
+
diff --git a/tests/test-04.hs b/tests/test-04.hs
new file mode 100644
--- /dev/null
+++ b/tests/test-04.hs
@@ -0,0 +1,248 @@
+
+{-# LANGUAGE CPP #-}
+
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE Rank2Types #-}
+{- LANGUAGE ScopedTypeVariables #-}
+
+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
+
+ module Main ( main ) where
+
+ import SAI.Data.Generics.Shape.SYB ( Homo, ghom )
+ import SAI.Data.Generics.Shape.SYB ( shapeOf, weightedShapeOf )
+ import SAI.Data.Generics.Shape.SYB ( showAsParens )
+ import SAI.Data.Generics.Shape.SYB ( showAsParensEnriched )
+ import SAI.Data.Generics.Shape.SYB ( filterHomo )
+--import SAI.Data.Generics.Shape.SYB ( ghomP )
+ import SAI.Data.Generics.Shape.SYB ( ghomP' )
+ import SAI.Data.Generics.Shape.SYB ( ghomP'' )
+ import Data.Data ( Data, Typeable )
+ import Data.Generics.Aliases ( mkQ, extQ )
+ import Data.Generics.Aliases ( GenericQ )
+ import Data.List ( intersperse )
+ import Control.Exception ( evaluate )
+ import Data.Function ( fix )
+
+--import SAI.Data.Generics.Shape.SYB.GHC -- this will add over 10 MB to the executable size (dynamically-linked!)
+
+ data TA = A1 | A2 TB TA TB deriving ( Data, Typeable )
+ data TB = B TA deriving ( Data, Typeable )
+ exprAB = A2 (B A1) A1 (B A1)
+
+---------------------------------------
+
+ -- often you would not have any Show instance for your
+ -- source types, but here it's useful for preparing
+ -- my writeup...
+ data TC = C1 Float (Int,Int) | C2 TD TC TD | C3 TC
+ deriving ( Show, Data, Typeable )
+-- deriving ( Data, Typeable )
+ data TD = D TC
+ deriving ( Show, Data, Typeable )
+-- deriving ( Data, Typeable )
+ exprCD = C2 (D (C1 1.1 (4,5))) (C3 (C1 2.2 (6,7))) (D (C1 3.3 (8,9)))
+
+ data Result = Result (Int,Int) deriving ( Show, Eq, Data, Typeable )
+--data Result = Result (Int,Int) deriving ( Show, Eq ) -- Eq for filterHomo
+--data Result = Result (Int,Int) deriving ( Show )
+ dud_result = Result (0,0)
+ pair_result pair = Result pair
+
+ test1 :: TC -> Homo Result
+ test1 = ghom (\r _->r) (mkQ dud_result f)
+ where
+ -- This is only generic in the sense that you don't
+ -- need to match all ctors; but nodes of other types
+ -- will still be traversed (passed over):
+-- f :: forall d. Data d => d -> Result
+ f (C1 _ pair) = pair_result pair
+ f (C2 _ _ d2@(D c)) = let g (Result (x,y)) = Result (y,x) in g (f c)
+-- f (C2 _ _ d2@(D c)) = f c -- line above is more interesting
+ f x = dud_result -- still needed! (notwithstanding mkQ)
+-- f x = x
+
+ test1' :: TC -> Homo Result
+ test1' = ghomP' p (\r _->r) (mkQ dud_result f)
+ where
+-- f :: forall d. Data d => d -> Result
+ f (C1 _ pair) = pair_result pair
+ f (C2 _ _ d2@(D c)) = let g (Result (x,y)) = Result (y,x) in g (f c)
+-- f (C2 _ _ d2@(D c)) = f c -- line above is more interesting
+ f x = dud_result
+-- f x = x
+-- p :: Homo Result -> Bool
+-- p (R (Result (x,y)) _) = not $ x == 0 && y == 0
+ p :: Result -> Bool
+ p (Result (x,y)) = not $ x == 0 && y == 0
+
+#if 1
+--test1'' :: TC -> Homo Result
+--test1'' = ghomP'' (mkQ True p) (\r _->r) (mkQ dud_result f)
+ test1'' = ghomP'' p' (\r _->r) (mkQ dud_result f)
+ where
+
+ f :: TC -> Result -- correct (but unneeded)
+--- f :: forall b. Data b => b -> Result -- wrong (we'd like it though)
+ f (C1 _ pair) = pair_result pair
+ f (C2 _ _ d2@(D c)) = let g (Result (x,y)) = Result (y,x) in g (f c)
+-- f (C2 _ _ d2@(D c)) = f c -- line above is more interesting
+ f x = dud_result
+
+ p :: TC -> Bool -- correct (but unneeded)
+--- p :: forall e. (Data e, Typeable e) => e -> Bool -- (would be nice)
+ p (C1 _ (i1,i2)) = i1 < 7
+-- p (C1 _ (i1,i2)) = i1 < i2
+-- p (C2 _ _ d2@(D c)) = p c
+ p x = True
+ -- one or the other sig. is NEEDED:
+-- p' :: forall d. (Data d, Typeable d) => d -> Bool
+ p' :: GenericQ Bool
+-- p' = mkQ True (\x -> p (x :: (forall d. (Data d, Typeable d) => d)))
+-- p' = mkQ True (\x -> p (x :: (forall d. (Data d) => d)))
+ p' = mkQ True p
+--mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
+--type GenericQ r = forall a. Data a => a -> r
+--data TC = C1 Float (Int,Int) | C2 TD TC TD deriving ( Data, Typeable )
+--data TD = D TC deriving ( Data, Typeable )
+#endif
+
+ test2 :: TC -> Homo Result
+ test2 = ghom (\r _->r) ((const dud_result) `extQ` fTC `extQ` fTD)
+ where
+
+ fTC :: TC -> Result
+ fTC (C1 _ pair) = pair_result pair
+ -- Note we don't need to cover all the cases, or provide a base case;
+ -- SYB provides the default case for us automatically.
+ fTC x = dud_result
+-- fTC x = x
+
+ fTD :: TD -> Result
+ fTD (D c) = Result (1,1)
+-- fTD (D c) = (mkQ (const dud_result) fTC) c -- why not?
+-- fTD (D c) = fTC c -- risk non-exhaustive patterns runtime errpr
+ fTD x = dud_result
+-- fTD x = x
+
+---------------------------------------
+
+ data CompanyType = Company [DepartmentType]
+ data DepartmentType = Department String ManagerType [EmployeeType]
+ data ManagerType = Manager { rank :: Float
+ , manName :: String
+ , manSalary :: SalaryType }
+ data EmployeeType = Employee { empName :: String
+ , empSalary :: SalaryType }
+ data SalaryType = Salary Float
+ deriving instance Data CompanyType
+ deriving instance Data DepartmentType
+ deriving instance Data ManagerType
+ deriving instance Data EmployeeType
+ deriving instance Data SalaryType
+ deriving instance Typeable CompanyType
+ deriving instance Typeable DepartmentType
+ deriving instance Typeable ManagerType
+ deriving instance Typeable EmployeeType
+ deriving instance Typeable SalaryType
+
+ data NiceRecord = NiceRecord { nice_name :: String
+ , nice_salary :: Int }
+ deriving ( Show, Eq )
+-- deriving ( Show )
+ dud_record = NiceRecord "" 0
+
+------------------------------
+
+ -- small, one department retail company
+ company1 = Company [Department "Sales" (Manager 1 "Deborah" (Salary 75000)) [Employee "Jane" (Salary 35000)]]
+
+ test3 :: CompanyType -> Homo ()
+--test3 :: forall d. Data d => d -> Homo ()
+ test3 = ghom (\_ _->()) (const ())
+
+--test4 :: EmployeeType -> Homo NiceRecord
+--test4 :: forall d. Data d => d -> Homo NiceRecord
+ test4 = ghom k (const dud_record `extQ` f_EmployeeType `extQ` f_ManagerType)
+--test4 = ghom k f
+ where
+ -- No sum types involved, so no explicit defaults
+ -- needed (unlike in previous examples).
+ f_EmployeeType (Employee name (Salary salary))
+ = NiceRecord name (floor salary)
+ f_ManagerType (Manager _ name _)
+ = NiceRecord name 0
+ k r _ = r
+
+-----------------------------------
+
+ main = do
+ evaluate (test4 company1)
+ putStrLn $ concat $ intersperse "\n" [ ""
+#if 0
+#elif 1
+-- , show $ test4' company1
+ , "show exprCD\n "
+ , show exprCD ++ "\n"
+ , "show $ shapeOf exprCD\n "
+ , show $ shapeOf exprCD
+ , "showAsParens $ shapeOf exprCD\n "
+ , (showAsParens $ shapeOf exprCD) ++ "\n"
+ , "showAsParens $ weightedShapeOf exprCD\n "
+ , (showAsParens $ weightedShapeOf exprCD) ++ "\n"
+ , "showAsParensEnriched $ weightedShapeOf exprCD\n "
+ , (showAsParensEnriched $ weightedShapeOf exprCD) ++ "\n"
+ , "show $ test1 exprCD\n "
+ , show $ test1 exprCD
+ , "show $ test1' exprCD\n "
+ , show $ test1' exprCD
+ , "show $ test1'' exprCD\n "
+ , show $ test1'' exprCD
+ , "show $ filterHomo p1 $ test1'' exprCD\n "
+ , show $ filterHomo p1 $ test1'' exprCD
+ , "show $ filterHomo p1 $ test1 exprCD\n "
+ , show $ filterHomo p1 $ test1 exprCD
+ , "show $ test2 exprCD\n "
+ , show $ test2 exprCD
+ , "show $ filterHomo p1 $ test2 exprCD\n "
+ , show $ filterHomo p1 $ test2 exprCD
+#elif 0
+ , show $ filterHomo p3 $ test4 company1
+#if 0
+ , show $ filterHomo p3 $ shapeOf exprAB
+#endif
+ , show $ weightedShapeOf exprAB
+ , show $ filterHomo p2 $ weightedShapeOf exprAB
+ , show $ weightedShapeOf ( [[1,2],[3],[4,5,6]] :: [[Int]] )
+ , show $ filterHomo p2 $ weightedShapeOf ( [[1,2],[3],[4,5,6]] :: [[Int]] )
+-- , show $ filterHomo p2 $ weightedShapeOf [[1,2],[3],[4,5,6]]
+-- , show $ test2 exprCD
+-- , show $ filterHomo p1 $ test2 exprCD
+ , show $ test1 exprCD
+-- , show $ fix (filterHomo p1) $ test1 exprCD
+ , show $ filterHomo p1 $ test1 exprCD
+-- , show $ filterHomo p1 $ filterHomo p1 $ test1 exprCD
+-- , show $ filterHomo p1 $ filterHomo p1 $ filterHomo p1 $ test1 exprCD
+-- , show $ filterHomo p1 $ filterHomo p1 $ filterHomo p1 $ filterHomo p1 $ test1 exprCD
+#elif 0
+ , showAsParens $ shapeOf company1
+ , show $ shapeOf company1
+ , show $ test3 company1
+ , show $ test4 company1
+ , show $ shapeOf exprAB
+ , show $ weightedShapeOf exprAB
+ , show $ weightedShapeOf ( [[1,2],[3],[4,5,6]] :: [[Int]] )
+-- , show $ weightedShapeOf [[1,2],[3],[4,5,6]]
+ , show $ test2 exprCD
+ , show $ test1 exprCD
+#endif
+ ]
+ where
+ p1 (Result (x,y)) = not $ x == 0 && y == 0
+ p2 x = x /= 3
+-- p2 x = x /= ( 3 :: Int )
+ p3 = (/= dud_record)
+
+-----------------------------------
+
diff --git a/tests/test-05.hs b/tests/test-05.hs
new file mode 100644
--- /dev/null
+++ b/tests/test-05.hs
@@ -0,0 +1,25 @@
+
+-------------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{- LANGUAGE NoMonomorphismRestriction #-}
+
+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
+
+-------------------------------------------------------------------------------
+
+ module Main ( main ) where
+
+-------------------------------------------------------------------------------
+
+ import ShapeSyb ( main_tests )
+ import Control.Monad ( void )
+
+ main = void main_tests >> return ()
+