sai-shape-syb (empty) → 0.2.0
raw patch · 22 files changed
+5620/−0 lines, 22 filesdep +HUnitdep +basedep +containerssetup-changed
Dependencies added: HUnit, base, containers, ghc, ghc-syb-utils, sai-shape-syb, syb
Files
- HTML/bigoutput.html +33/−0
- HTML/ghc.html +483/−0
- HTML/ghc1.html +475/−0
- HTML/ghc2.html +868/−0
- HTML/index.html +16/−0
- HTML/sai-shape-syb.html +693/−0
- HTML/style.css +3/−0
- HTML/test-code.html +21/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- sai-shape-syb.cabal +202/−0
- src/SAI/Data/Generics/Shape.hs +50/−0
- src/SAI/Data/Generics/Shape/SYB.hs +763/−0
- src/SAI/Data/Generics/Shape/SYB/Filter.hs +685/−0
- src/SAI/Data/Generics/Shape/SYB/GHC.hs +204/−0
- tests/Main.hs +46/−0
- tests/ShapeSyb.hs +581/−0
- tests/test-01.hs +49/−0
- tests/test-02.hs +72/−0
- tests/test-03.hs +71/−0
- tests/test-04.hs +248/−0
- tests/test-05.hs +25/−0
+ HTML/bigoutput.html view
@@ -0,0 +1,33 @@++<!DOCTYPE html>+<html>+<head>+<title>Generic shapeOf etc. - Big Output</title>+<link rel="stylesheet" href="style.css" />+</head>+<body>++<!--div style="margin-left: 15px;">+Want to cut to the chase?<br>+See the bottom of the page for a concise <a href="#contrib">contribution statement</a>.+</div-->++<h2>Big Trees Result!</h2>++<pre>++((((()(()(()(()(()())))))(()(()(()(()(()(()(()(()())))))))(()))(((()(()(()(()()))))(()))()))()))+R () [R () [R () [R () [R () [],R () [R () [],R () [R () [],R () [R () [],R () [R () [],R () []]]]]],R () [R () [],R () [R () [],R () [R () [],R () [R () [],R () [R () [],R () [R () [],R () [R () [],R () [R () [],R () []]]]]]]],R () [R () []]],R () [R () [R () [R () [],R () [R () [],R () [R () [],R () [R () [],R () []]]]],R () [R () []]],R () []]],R () []]]+R () [R () [R () [R () [R () [],R () [R () [],R () [R () [],R () [R () [],R () [R () [],R () []]]]]],R () [R () [],R () [R () [],R () [R () [],R () [R () [],R () [R () [],R () [R () [],R () [R () [],R () [R () [],R () []]]]]]]],R () [R () []]],R () [R () [R () [R () [],R () [R () [],R () [R () [],R () [R () [],R () []]]]],R () [R () []]],R () []]],R () []]]+R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) []]]]]],R (NiceRecord {nice_name = "Deborah", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) []]]]]]]],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) []]],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "Jane", nice_salary = 35000}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) [],R (NiceRecord {nice_name = "", nice_salary = 0}) []]]]],R (NiceRecord {nice_name = "", nice_salary = 0}) [R (NiceRecord {nice_name = "", nice_salary = 0}) []]],R (NiceRecord {nice_name = "", nice_salary = 0}) []]],R (NiceRecord {nice_name = "", nice_salary = 0}) []]]+R () [R () [R () []],R () [],R () [R () []]]+R 6 [R 2 [R 1 []],R 1 [],R 2 [R 1 []]]+R 19 [R 5 [R 1 [],R 3 [R 1 [],R 1 []]],R 13 [R 3 [R 1 [],R 1 []],R 9 [R 7 [R 1 [],R 5 [R 1 [],R 3 [R 1 [],R 1 []]]],R 1 []]]]+R (Result (0,0)) [R (Result (1,1)) [R (Result (1,2)) [R (Result (0,0)) [],R (Result (0,0)) [R (Result (0,0)) [],R (Result (0,0)) []]]],R (Result (3,4)) [R (Result (0,0)) [],R (Result (0,0)) [R (Result (0,0)) [],R (Result (0,0)) []]],R (Result (1,1)) [R (Result (5,6)) [R (Result (0,0)) [],R (Result (0,0)) [R (Result (0,0)) [],R (Result (0,0)) []]]]]+R (Result (5,6)) [R (Result (0,0)) [R (Result (1,2)) [R (Result (0,0)) [],R (Result (0,0)) [R (Result (0,0)) [],R (Result (0,0)) []]]],R (Result (3,4)) [R (Result (0,0)) [],R (Result (0,0)) [R (Result (0,0)) [],R (Result (0,0)) []]],R (Result (0,0)) [R (Result (5,6)) [R (Result (0,0)) [],R (Result (0,0)) [R (Result (0,0)) [],R (Result (0,0)) []]]]]++</pre>++</body>+</html>+
+ HTML/ghc.html view
@@ -0,0 +1,483 @@++<!DOCTYPE html>+<html>+<head>+<title>Generic shapeOf etc. - GHC</title>+<link rel="stylesheet" href="style.css" />+</head>+<body>++<h2>Dealing with GHC Staging Holes</h2>++GHC AST has some funny types which "blow up" if you examine them.+SYB works by attempting <tt>unsafeCoerce</tt>'s, which triggers these holes.+We need a "staged" version of <tt>ghom</tt> (at least).+The HaRe source contains a good model of this (its GhcUtils.hs module).+Using that I made <tt>ghomStaged</tt>++<pre>++ 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])++</pre>++<tt>checkItemStage</tt> is from HaRe and can be found in the+<a href="sai-shape-syb-0.2.0.tar.gz">download</a>.+<br>+Note also you will need to have <a href="http://hackage.haskell.org/package/ghc-syb-utils">ghc-syb-utils</a> installed for these experiments.++<p>+Without worrying about its content, here is a small sample module we parse into an AST using the GHC API++<pre>++ -- 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)++</pre>++<a href="ghc1.html">This page</a> shows the monstrous, usual output if we show the typechecked AST for the above small sample module.++We can summarise its structure thus++<pre>++liftIO $ putStrLn $ showAsParens $ shapeOfStaged typechecked++(((()((()(()(()())))(()(()(()())))((()()(((((())((())(())))((())((())(()))))(+()))(((((()))((())))((())))((((()))((())))((())))))(()))())()(((()((()())()((+(()(((()(()))((()(((()(()))((()(()))()))()(()((())((())())))))()))()(((()((((+)((()((()((((()))((())))(())))(()(()))))((()))((()))(()())))())(()((((()(()))+)(((()((()(()))(()((((()))((())))(())))(()())(()(((())()((()((((()))((())))((+))))(()((()(()())))))(())))))))()))()))))((()(((()((()(()))((()))((()))(()())+))())(()((((()((()(()))(()((((()))((())))(())))(()())(()(((())()((()((((()))(+(())))(())))(()((()(()())))))(())))))))(((()(())))()))()))))()))())))())((())+((()((())((())())))(()((())((())()))))))()()()))()))))((()((()(()(()())))(()(+()(()())))((()()(((((())((())(())))((())((())(()))))(()))(((((()))((())))((()+)))((((()))((())))((())))))(()))())()(((()((()())()(((()(((()((()())()()()(()+)(()((())()))))((()(()))()))()(((()(()(()(()))))())())))((()(((()((()((()())(+)()()((()(()))(()(())))(()((())()))))))((()(()))()))()(((()(()(()((()((()(())+)(()(()))))(()((()((()((()((((((()))((())))((())))((((()))((())))((()))))(())+))(()(()))))(()(()))))))))))())())))()))((()((())()))((()((())((())())))(()((+())((())()))))))()()()))()))))((()(()()((()()()(()))())()(((()((()())()(((()(+()()(((()(()(()((()(((()((()())((()())()))))(())))(()((()((()((()((((((()))((+())))((())))((((()()))((()())))((()()))))(())))(()(((((()))((()())))(()))((()+(((())()((()((((()))((()())))(())))(()((()(()())))))(()()))))(()(((())()((()(+(((()))((()())))(())))(()((()(()())))))(()())))))))))(()((((()((()(((())()(((+)))(()()))))(()(())))))(((()((()(((())()((()))(()()))))(()(())))))()))())))))+)))))())())))())(()((()((()())((()())())))())))()()()))()))))()))))++</pre>++And <a href="ghc2.html">this page</a> shows the result of <tt>weightedShapeOfStaged</tt> applied to the staged GHC AST. These prove that our staged version works.++<p>+Note that you do get a runtime error if you use <tt>weightedShapeOf</tt> (the unstaged version).+You can see one such hole in the first line below++<pre>+ .+ .+ .+ (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++</pre>++Finally, let's use <tt>filterHomo</tt> 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, <tt>Homo Int</tt>.++<p>+Filtering all nodes with weight at least 5++<pre>++let xxx = weightedShapeOfStaged TypeChecker typechecked+liftIO $ putStrLn $ show $ filterHomo (>=5) xxx++842+ 841+ 334+ 332+ 7+ 5+ 7+ 5+ 51+ 49+ 44+ 20+ 17+ 8+ 5+ 8+ 5+ 23+ 11+ 7+ 11+ 7+ 265+ 264+ 262+ 260+ 252+ 229+ 227+ 225+ 31+ 26+ 24+ 22+ 11+ 6+ 9+ 7+ 192+ 190+ 101+ 99+ 33+ 31+ 29+ 19+ 17+ 12+ 10+ 7+ 65+ 63+ 61+ 5+ 55+ 53+ 52+ 50+ 12+ 10+ 7+ 30+ 28+ 27+ 21+ 12+ 10+ 7+ 8+ 6+ 5+ 88+ 86+ 84+ 18+ 16+ 14+ 65+ 63+ 61+ 53+ 52+ 50+ 12+ 10+ 7+ 30+ 28+ 27+ 21+ 12+ 10+ 7+ 8+ 6+ 5+ 7+ 5+ 22+ 19+ 9+ 7+ 9+ 7+ 506+ 257+ 255+ 7+ 5+ 7+ 5+ 51+ 49+ 44+ 20+ 17+ 8+ 5+ 8+ 5+ 23+ 11+ 7+ 11+ 7+ 188+ 187+ 185+ 183+ 175+ 148+ 40+ 38+ 24+ 17+ 15+ 6+ 6+ 12+ 10+ 8+ 6+ 107+ 105+ 103+ 34+ 27+ 25+ 24+ 22+ 9+ 6+ 6+ 67+ 65+ 63+ 61+ 59+ 57+ 11+ 9+ 45+ 43+ 42+ 40+ 35+ 33+ 28+ 26+ 23+ 11+ 7+ 11+ 7+ 26+ 6+ 19+ 9+ 7+ 9+ 7+ 248+ 246+ 244+ 8+ 6+ 232+ 231+ 229+ 227+ 219+ 203+ 201+ 199+ 196+ 194+ 192+ 190+ 188+ 186+ 17+ 15+ 12+ 11+ 9+ 5+ 168+ 166+ 165+ 163+ 113+ 111+ 31+ 29+ 26+ 11+ 7+ 14+ 9+ 79+ 77+ 11+ 8+ 65+ 32+ 30+ 29+ 22+ 13+ 11+ 8+ 8+ 6+ 5+ 32+ 30+ 29+ 22+ 13+ 11+ 8+ 8+ 6+ 5+ 49+ 47+ 45+ 21+ 20+ 18+ 13+ 11+ 10+ 23+ 21+ 20+ 18+ 13+ 11+ 10+ 15+ 13+ 11+ 9+ 5++</pre>++And again, filtering all nodes with weight at least 50++<pre>++let xxx = weightedShapeOfStaged TypeChecker typechecked+liftIO $ putStrLn $ show $ filterHomo (>=50) xxx++842+ 841+ 334+ 332+ 51+ 265+ 264+ 262+ 260+ 252+ 229+ 227+ 225+ 192+ 190+ 101+ 99+ 65+ 63+ 61+ 55+ 53+ 52+ 50+ 88+ 86+ 84+ 65+ 63+ 61+ 53+ 52+ 50+ 506+ 257+ 255+ 51+ 188+ 187+ 185+ 183+ 175+ 148+ 107+ 105+ 103+ 67+ 65+ 63+ 61+ 59+ 57+ 248+ 246+ 244+ 232+ 231+ 229+ 227+ 219+ 203+ 201+ 199+ 196+ 194+ 192+ 190+ 188+ 186+ 168+ 166+ 165+ 163+ 113+ 111+ 79+ 77+ 65++</pre>++<br><br><br><br>++</body>+</html>+
+ HTML/ghc1.html view
@@ -0,0 +1,475 @@++<!DOCTYPE html>+<html>+<head>+<title>Generic shapeOf etc. - GHC1</title>+<link rel="stylesheet" href="style.css" />+</head>+<body>++<br>+Here's our sample Haskell module for playing with the GHC AST++<pre>++ -- 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)++</pre>++<br>+This is the usual way to show the GHC AST++<pre>++(printForUser dflags stdout unqual . shown TypeChecker) typechecked++{Bag(Located (HsBind Var)): +[+ (L {A06.hs:(14,3)-(15,44)} + (AbsBinds + [{Var: a},{Var: t},{Var: t}] + [{Var: $dIntegral},{Var: $dNum},{Var: $dNum}] + [+ (ABE {Var: A06.tick} {Var: tick} + (WpCompose + (WpCompose + (WpCompose + (WpCompose + (WpTyLam {Var: a}) + (WpCompose + (WpTyLam {Var: t}) + (WpTyLam {Var: t}))) + (WpCompose + (WpEvLam {Var: $dIntegral}) + (WpCompose + (WpEvLam {Var: $dNum}) + (WpEvLam {Var: $dNum})))) + (WpLet + ({abstract:TcEvBinds}))) + (WpCompose + (WpCompose + (WpCompose + (WpEvApp + (EvId {Var: $dNum})) + (WpEvApp + (EvId {Var: $dNum}))) + (WpEvApp + (EvId {Var: $dIntegral}))) + (WpCompose + (WpCompose + (WpTyApp t) + (WpTyApp t)) + (WpTyApp a)))) + (SpecPrags + []))] + ({abstract:TcEvBinds}) {Bag(Located (HsBind Var)): + [+ (L {A06.hs:(14,3)-(15,44)} + (FunBind + (L {A06.hs:14:3-6} {Var: tick}) + (False) + (MatchGroup + [+ (L {A06.hs:(14,3)-(15,44)} + (Match + [+ (L {A06.hs:14:8} + (VarPat {Var: x})),+ (L {A06.hs:14:10-17} + (TuplePat + [+ (L {A06.hs:14:11-12} + (VarPat {Var: c0})),+ (L {A06.hs:14:15-16} + (VarPat {Var: c1}))] + (Boxed) (t, t)))] + (Nothing) + (GRHSs + [+ (L {A06.hs:14:19-44} + (GRHS + [+ (L {A06.hs:14:21-26} + (ExprStmt + (L {A06.hs:14:21-26} + (HsApp + (L {A06.hs:14:21-24} + (HsWrap + (WpCompose + (WpEvApp + (EvId {Var: $dIntegral})) + (WpTyApp a)) + (HsVar {Var: GHC.Real.even}))) + (L {A06.hs:14:26} + (HsVar {Var: x})))) + (HsLit + (HsString {FastString: "noSyntaxExpr"})) + (HsLit + (HsString {FastString: "noSyntaxExpr"})) GHC.Types.Bool))] + (L {A06.hs:14:33-44} + (ExplicitTuple + [+ (Present + (L {A06.hs:14:34-35} + (HsVar {Var: c0}))),+ (Present + (L {A06.hs:14:38-43} + (OpApp + (L {A06.hs:14:38-39} + (HsVar {Var: c1})) + (L {A06.hs:14:41} + (HsWrap + (WpCompose + (WpEvApp + (EvId {Var: $dNum})) + (WpTyApp t)) + (HsVar {Var: GHC.Num.+}))) {Fixity: infixl 6} + (L {A06.hs:14:43} + (HsOverLit + (OverLit + (HsIntegral + (1)) + (False) + (HsApp + (L {<no location info>} + (HsWrap + (WpCompose + (WpEvApp + (EvId {Var: $dNum})) + (WpTyApp t)) + (HsVar {Var: GHC.Num.fromInteger}))) + (L {<no location info>} + (HsLit + (HsInteger + (1) GHC.Integer.Type.Integer)))) t))))))] + (Boxed))))),+ (L {A06.hs:15:19-44} + (GRHS + [+ (L {A06.hs:15:21-29} + (ExprStmt + (L {A06.hs:15:21-29} + (HsVar {Var: GHC.Base.otherwise})) + (HsLit + (HsString {FastString: "noSyntaxExpr"})) + (HsLit + (HsString {FastString: "noSyntaxExpr"})) GHC.Types.Bool))] + (L {A06.hs:15:33-44} + (ExplicitTuple + [+ (Present + (L {A06.hs:15:34-39} + (OpApp + (L {A06.hs:15:34-35} + (HsVar {Var: c0})) + (L {A06.hs:15:37} + (HsWrap + (WpCompose + (WpEvApp + (EvId {Var: $dNum})) + (WpTyApp t)) + (HsVar {Var: GHC.Num.+}))) {Fixity: infixl 6} + (L {A06.hs:15:39} + (HsOverLit + (OverLit + (HsIntegral + (1)) + (False) + (HsApp + (L {<no location info>} + (HsWrap + (WpCompose + (WpEvApp + (EvId {Var: $dNum})) + (WpTyApp t)) + (HsVar {Var: GHC.Num.fromInteger}))) + (L {<no location info>} + (HsLit + (HsInteger + (1) GHC.Integer.Type.Integer)))) t)))))),+ (Present + (L {A06.hs:15:42-43} + (HsVar {Var: c1})))] + (Boxed)))))] + (EmptyLocalBinds))))] a -> (t, t) -> (t, t)) + (WpHole) {!NameSet placeholder here!} + (Nothing)))]})),+ (L {A06.hs:(11,3)-(12,30)} + (AbsBinds + [{Var: a},{Var: t},{Var: t}] + [{Var: $dIntegral},{Var: $dNum},{Var: $dNum}] + [+ (ABE {Var: A06.f} {Var: f} + (WpCompose + (WpCompose + (WpCompose + (WpCompose + (WpTyLam {Var: a}) + (WpCompose + (WpTyLam {Var: t}) + (WpTyLam {Var: t}))) + (WpCompose + (WpEvLam {Var: $dIntegral}) + (WpCompose + (WpEvLam {Var: $dNum}) + (WpEvLam {Var: $dNum})))) + (WpLet + ({abstract:TcEvBinds}))) + (WpCompose + (WpCompose + (WpCompose + (WpEvApp + (EvId {Var: $dNum})) + (WpEvApp + (EvId {Var: $dNum}))) + (WpEvApp + (EvId {Var: $dIntegral}))) + (WpCompose + (WpCompose + (WpTyApp t) + (WpTyApp t)) + (WpTyApp a)))) + (SpecPrags + []))] + ({abstract:TcEvBinds}) {Bag(Located (HsBind Var)): + [+ (L {A06.hs:(11,3)-(12,30)} + (FunBind + (L {A06.hs:11:3} {Var: f}) + (False) + (MatchGroup + [+ (L {A06.hs:11:3-16} + (Match + [+ (L {A06.hs:11:5-6} + (ConPatOut + (L {A06.hs:11:5-6} {DataCon: []}) + [] + [] + ({abstract:TcEvBinds}) + (PrefixCon + []) [a])),+ (L {A06.hs:11:12} + (VarPat {Var: c}))] + (Nothing) + (GRHSs + [+ (L {A06.hs:11:16} + (GRHS + [] + (L {A06.hs:11:16} + (HsVar {Var: c}))))] + (EmptyLocalBinds)))),+ (L {A06.hs:12:3-30} + (Match + [+ (L {A06.hs:12:5-10} + (ParPat + (L {A06.hs:12:6-9} + (ConPatOut + (L {A06.hs:12:7} {DataCon: :}) + [] + [] + ({abstract:TcEvBinds}) + (InfixCon + (L {A06.hs:12:6} + (VarPat {Var: x})) + (L {A06.hs:12:8-9} + (VarPat {Var: xs}))) [a])))),+ (L {A06.hs:12:12} + (VarPat {Var: c}))] + (Nothing) + (GRHSs + [+ (L {A06.hs:12:16-30} + (GRHS + [] + (L {A06.hs:12:16-30} + (HsApp + (L {A06.hs:12:16-19} + (HsApp + (L {A06.hs:12:16} + (HsVar {Var: f})) + (L {A06.hs:12:18-19} + (HsVar {Var: xs})))) + (L {A06.hs:12:21-30} + (HsPar + (L {A06.hs:12:22-29} + (HsApp + (L {A06.hs:12:22-27} + (HsApp + (L {A06.hs:12:22-25} + (HsWrap + (WpCompose + (WpCompose + (WpCompose + (WpEvApp + (EvId {Var: $dNum})) + (WpEvApp + (EvId {Var: $dNum}))) + (WpEvApp + (EvId {Var: $dIntegral}))) + (WpCompose + (WpCompose + (WpTyApp t) + (WpTyApp t)) + (WpTyApp a))) + (HsVar {Var: A06.tick}))) + (L {A06.hs:12:27} + (HsVar {Var: x})))) + (L {A06.hs:12:29} + (HsVar {Var: c}))))))))))] + (EmptyLocalBinds))))] [a] -> (t, t) -> (t, t)) + (WpHole) {!NameSet placeholder here!} + (Nothing)))]})),+ (L {A06.hs:9:3-55} + (AbsBinds + [] + [] + [+ (ABE {Var: A06.main} {Var: main} + (WpHole) + (SpecPrags + []))] + ({abstract:TcEvBinds}) {Bag(Located (HsBind Var)): + [+ (L {A06.hs:9:3-55} + (FunBind + (L {A06.hs:9:3-6} {Var: main}) + (False) + (MatchGroup + [+ (L {A06.hs:9:3-55} + (Match + [] + (Nothing) + (GRHSs + [+ (L {A06.hs:9:10-55} + (GRHS + [] + (L {A06.hs:9:10-55} + (HsApp + (L {A06.hs:9:10-17} + (HsWrap + (WpTyApp (GHC.Types.Int, GHC.Types.Int)) + (HsVar {Var: GHC.IO.evaluate}))) + (L {A06.hs:9:19-55} + (HsPar + (L {A06.hs:9:20-54} + (HsApp + (L {A06.hs:9:20-33} + (HsApp + (L {A06.hs:9:20} + (HsWrap + (WpCompose + (WpCompose + (WpCompose + (WpEvApp + (EvId {Var: $dNum})) + (WpEvApp + (EvId {Var: $dNum}))) + (WpEvApp + (EvId {Var: $dIntegral}))) + (WpCompose + (WpCompose + (WpTyApp GHC.Types.Int) + (WpTyApp GHC.Types.Int)) + (WpTyApp GHC.Integer.Type.Integer))) + (HsVar {Var: A06.f}))) + (L {A06.hs:9:22-33} + (ArithSeq + (HsWrap + (WpCompose + (WpEvApp + (EvId {Var: $dEnum})) + (WpTyApp GHC.Integer.Type.Integer)) + (HsVar {Var: GHC.Enum.enumFromTo})) + (FromTo + (L {A06.hs:9:23} + (HsOverLit + (OverLit + (HsIntegral + (1)) + (False) + (HsApp + (L {<no location info>} + (HsWrap + (WpCompose + (WpEvApp + (EvId {Var: $dNum})) + (WpTyApp GHC.Integer.Type.Integer)) + (HsVar {Var: GHC.Num.fromInteger}))) + (L {<no location info>} + (HsLit + (HsInteger + (1) GHC.Integer.Type.Integer)))) GHC.Integer.Type.Integer))) + (L {A06.hs:9:26-32} + (HsOverLit + (OverLit + (HsIntegral + (4000000)) + (False) + (HsApp + (L {<no location info>} + (HsWrap + (WpCompose + (WpEvApp + (EvId {Var: $dNum})) + (WpTyApp GHC.Integer.Type.Integer)) + (HsVar {Var: GHC.Num.fromInteger}))) + (L {<no location info>} + (HsLit + (HsInteger + (4000000) GHC.Integer.Type.Integer)))) GHC.Integer.Type.Integer)))))))) + (L {A06.hs:9:35-54} + (ExplicitTuple + [+ (Present + (L {A06.hs:9:36-43} + (ExprWithTySigOut + (L {A06.hs:9:36} + (HsOverLit + (OverLit + (HsIntegral + (0)) + (False) + (HsLit + (HsInt + (0))) GHC.Types.Int))) + (L {A06.hs:9:41-43} + (HsTyVar {Name: GHC.Types.Int}))))),+ (Present + (L {A06.hs:9:46-53} + (ExprWithTySigOut + (L {A06.hs:9:46} + (HsOverLit + (OverLit + (HsIntegral + (1)) + (False) + (HsLit + (HsInt + (1))) GHC.Types.Int))) + (L {A06.hs:9:51-53} + (HsTyVar {Name: GHC.Types.Int})))))] + (Boxed)))))))))))] + (EmptyLocalBinds))))] GHC.Types.IO (GHC.Types.Int, GHC.Types.Int)) + (WpHole) {!NameSet placeholder here!} + (Nothing)))]}))]}++</pre>++<br><br><br><br>++</body>+</html>+
+ HTML/ghc2.html view
@@ -0,0 +1,868 @@++<!DOCTYPE html>+<html>+<head>+<title>Generic shapeOf etc. - GHC2</title>+<link rel="stylesheet" href="style.css" />+</head>+<body>++<br>+Showing a particular mapping to the homogeneous result type <tt>Homo Int</tt>.+(Compare to <a href="ghc1.html">the original</a>.)+<br>++<pre>++liftIO $ putStrLn $ show $ weightedShapeOfStaged TypeChecker typechecked++842+ 841+ 334+ 1+ 332+ 7+ 1+ 5+ 1+ 3+ 1+ 1+ 7+ 1+ 5+ 1+ 3+ 1+ 1+ 51+ 49+ 1+ 1+ 44+ 20+ 17+ 8+ 2+ 1+ 5+ 2+ 1+ 2+ 1+ 8+ 2+ 1+ 5+ 2+ 1+ 2+ 1+ 2+ 1+ 23+ 11+ 7+ 3+ 2+ 1+ 3+ 2+ 1+ 3+ 2+ 1+ 11+ 7+ 3+ 2+ 1+ 3+ 2+ 1+ 3+ 2+ 1+ 2+ 1+ 1+ 1+ 265+ 264+ 262+ 1+ 260+ 3+ 1+ 1+ 1+ 252+ 229+ 227+ 1+ 225+ 31+ 4+ 1+ 2+ 1+ 26+ 24+ 1+ 22+ 11+ 4+ 1+ 2+ 1+ 6+ 4+ 1+ 2+ 1+ 1+ 1+ 9+ 1+ 7+ 2+ 1+ 4+ 2+ 1+ 1+ 1+ 1+ 192+ 190+ 101+ 1+ 99+ 33+ 31+ 1+ 29+ 19+ 1+ 17+ 12+ 1+ 10+ 7+ 3+ 2+ 1+ 3+ 2+ 1+ 2+ 1+ 4+ 1+ 2+ 1+ 3+ 2+ 1+ 3+ 2+ 1+ 3+ 1+ 1+ 1+ 65+ 1+ 63+ 61+ 5+ 4+ 1+ 2+ 1+ 55+ 53+ 52+ 1+ 50+ 4+ 1+ 2+ 1+ 12+ 1+ 10+ 7+ 3+ 2+ 1+ 3+ 2+ 1+ 2+ 1+ 3+ 1+ 1+ 30+ 1+ 28+ 27+ 2+ 1+ 1+ 21+ 12+ 1+ 10+ 7+ 3+ 2+ 1+ 3+ 2+ 1+ 2+ 1+ 8+ 1+ 6+ 5+ 1+ 3+ 1+ 1+ 2+ 1+ 1+ 1+ 88+ 86+ 1+ 84+ 18+ 16+ 1+ 14+ 4+ 1+ 2+ 1+ 3+ 2+ 1+ 3+ 2+ 1+ 3+ 1+ 1+ 1+ 65+ 1+ 63+ 61+ 53+ 52+ 1+ 50+ 4+ 1+ 2+ 1+ 12+ 1+ 10+ 7+ 3+ 2+ 1+ 3+ 2+ 1+ 2+ 1+ 3+ 1+ 1+ 30+ 1+ 28+ 27+ 2+ 1+ 1+ 21+ 12+ 1+ 10+ 7+ 3+ 2+ 1+ 3+ 2+ 1+ 2+ 1+ 8+ 1+ 6+ 5+ 1+ 3+ 1+ 1+ 2+ 1+ 7+ 5+ 4+ 1+ 2+ 1+ 1+ 1+ 1+ 1+ 1+ 22+ 2+ 1+ 19+ 9+ 1+ 7+ 2+ 1+ 4+ 2+ 1+ 1+ 9+ 1+ 7+ 2+ 1+ 4+ 2+ 1+ 1+ 1+ 1+ 1+ 1+ 506+ 257+ 1+ 255+ 7+ 1+ 5+ 1+ 3+ 1+ 1+ 7+ 1+ 5+ 1+ 3+ 1+ 1+ 51+ 49+ 1+ 1+ 44+ 20+ 17+ 8+ 2+ 1+ 5+ 2+ 1+ 2+ 1+ 8+ 2+ 1+ 5+ 2+ 1+ 2+ 1+ 2+ 1+ 23+ 11+ 7+ 3+ 2+ 1+ 3+ 2+ 1+ 3+ 2+ 1+ 11+ 7+ 3+ 2+ 1+ 3+ 2+ 1+ 3+ 2+ 1+ 2+ 1+ 1+ 1+ 188+ 187+ 185+ 1+ 183+ 3+ 1+ 1+ 1+ 175+ 148+ 40+ 1+ 38+ 24+ 17+ 1+ 15+ 3+ 1+ 1+ 1+ 1+ 1+ 2+ 1+ 6+ 1+ 4+ 2+ 1+ 1+ 6+ 4+ 1+ 2+ 1+ 1+ 1+ 12+ 10+ 8+ 1+ 6+ 1+ 4+ 1+ 2+ 1+ 1+ 1+ 107+ 105+ 1+ 103+ 34+ 27+ 1+ 25+ 24+ 1+ 22+ 3+ 1+ 1+ 1+ 1+ 1+ 9+ 4+ 1+ 2+ 1+ 4+ 1+ 2+ 1+ 6+ 1+ 4+ 2+ 1+ 1+ 6+ 4+ 1+ 2+ 1+ 1+ 1+ 67+ 65+ 63+ 1+ 61+ 1+ 59+ 1+ 57+ 11+ 1+ 9+ 4+ 1+ 2+ 1+ 4+ 1+ 2+ 1+ 45+ 1+ 43+ 42+ 1+ 40+ 35+ 1+ 33+ 28+ 1+ 26+ 23+ 11+ 7+ 3+ 2+ 1+ 3+ 2+ 1+ 3+ 2+ 1+ 11+ 7+ 3+ 2+ 1+ 3+ 2+ 1+ 3+ 2+ 1+ 2+ 1+ 4+ 1+ 2+ 1+ 4+ 1+ 2+ 1+ 1+ 1+ 1+ 26+ 6+ 1+ 4+ 2+ 1+ 1+ 19+ 9+ 1+ 7+ 2+ 1+ 4+ 2+ 1+ 1+ 9+ 1+ 7+ 2+ 1+ 4+ 2+ 1+ 1+ 1+ 1+ 1+ 1+ 248+ 246+ 1+ 244+ 1+ 1+ 8+ 6+ 1+ 1+ 1+ 2+ 1+ 1+ 1+ 232+ 231+ 229+ 1+ 227+ 3+ 1+ 1+ 1+ 219+ 203+ 201+ 1+ 199+ 1+ 1+ 196+ 194+ 192+ 1+ 190+ 1+ 188+ 1+ 186+ 17+ 1+ 15+ 12+ 11+ 1+ 9+ 3+ 1+ 1+ 5+ 3+ 1+ 1+ 1+ 2+ 1+ 168+ 1+ 166+ 165+ 1+ 163+ 113+ 1+ 111+ 31+ 1+ 29+ 26+ 11+ 7+ 3+ 2+ 1+ 3+ 2+ 1+ 3+ 2+ 1+ 14+ 9+ 4+ 3+ 1+ 1+ 4+ 3+ 1+ 1+ 4+ 3+ 1+ 1+ 2+ 1+ 79+ 1+ 77+ 11+ 8+ 3+ 2+ 1+ 4+ 3+ 1+ 1+ 2+ 1+ 65+ 32+ 1+ 30+ 29+ 2+ 1+ 1+ 22+ 13+ 1+ 11+ 8+ 3+ 2+ 1+ 4+ 3+ 1+ 1+ 2+ 1+ 8+ 1+ 6+ 5+ 1+ 3+ 1+ 1+ 3+ 1+ 1+ 32+ 1+ 30+ 29+ 2+ 1+ 1+ 22+ 13+ 1+ 11+ 8+ 3+ 2+ 1+ 4+ 3+ 1+ 1+ 2+ 1+ 8+ 1+ 6+ 5+ 1+ 3+ 1+ 1+ 3+ 1+ 1+ 49+ 1+ 47+ 45+ 21+ 20+ 1+ 18+ 13+ 1+ 11+ 10+ 2+ 1+ 1+ 3+ 2+ 1+ 3+ 1+ 1+ 4+ 1+ 2+ 1+ 23+ 21+ 20+ 1+ 18+ 13+ 1+ 11+ 10+ 2+ 1+ 1+ 3+ 2+ 1+ 3+ 1+ 1+ 4+ 1+ 2+ 1+ 1+ 1+ 1+ 1+ 1+ 15+ 1+ 13+ 11+ 1+ 9+ 3+ 1+ 1+ 5+ 3+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1++</pre>++<br><br><br><br>++</body>+</html>+
+ HTML/index.html view
@@ -0,0 +1,16 @@+<!DOCTYPE html>+<html>+<head>+<title>Haskell Generic shapeOf, etc.</title>+</head>+<body>++<div style="color: #F33; margin-top: 40px; font-size: 16pt;">+(Notes to self.)+</div>++<script>document.location = "sai-shape-syb.html";</script>++</body>+</html>+
+ HTML/sai-shape-syb.html view
@@ -0,0 +1,693 @@+<!DOCTYPE html>+<html>+<head>+<title>Generic shapeOf, and more General Homomorphisms</title>+<link rel="stylesheet" href="style.css" />+</head>+<body>++<h2>Download</h2>++Here's <a href="sai-shape-syb-0.2.0.tar.gz">full source</a> (BSD3-licensed, Cabal sdist) for:+<ul>+<li>building the library (providing <tt>Data.Generics.Shape.{SYB, SYB.Filter, SYB.GHC}</tt>), and+<li>building the testbench corresponding to the examples in this post.+</ul>++<h2>Generic Shape</h2>++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.++<p>+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...++<p>+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 <a href="http://hackage.haskell.org/package/shapely-data">shapely-data</a> and <a href="http://hackage.haskell.org/package/fixplate">fixplate</a>.++<p>+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 <tt>shapely-data</tt> and perhaps <tt>fixplate</tt>.+I feel humbled when I look at the beautiful API for <tt>shapely-data</tt>, 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.++<p>+This implementation:+<ul>+<li>provides a <tt>SYB</tt> alternative (<tt>shapely-data</tt> uses Template Haskell, and <tt>fixplate</tt> uses Uniplate)+<li>provides "staged" variants of key functions, needed to work with the GHC API+<li>my code is much smaller than either of those libraries, so that we can talk about all of it in one post.+</ul>++<h2>Code and Examples</h2>++<p>+Homomorphism can preserve some value information, in addition to the structure, mapping to a k-ary tree of homogeneous type, such as <tt>Rose a</tt>++<pre>++ data Rose a = R a [Rose a]++</pre>++with the constant-valued ("parentheses langauge") representation obtained for+<!--span><tt style="background-color: #DDD;">a</tt><tt> ~ ()</tt>.</span-->+<span><tt>a ~ ()</tt>.</span>++<p>+Achieving this for a homogeneous recursive source type is straightforward.+However, we would like a generic solution, to handle arbitrary (heterogeneous) recursive types.++<p>+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 <a href="http://hackage.haskell.org/package/syb">SYB package</a>.++<p>+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 <a href="http://marc.info/?l=haskell-generics&m=121665568609280">gmap</a>), 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 <tt>fmap</tt>, 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. :)+<p>++What I came up with is summarised in the following code+<pre>++ {-# 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])++</pre>++(If you use <tt>(nod:chs)</tt> the structure will be flipped horizontally.)+<p>++From this we can easily write the desired generic <tt>shapeOf</tt>++<pre>++ shapeOf :: forall d. Data d => d -> Shape+ shapeOf = ghom (\_ _->()) (const ())++</pre>++Without more ado, it's also possible to write a function which maps arbitrary data to its weighted tree representation++<pre>++ weightedShapeOf :: forall d. Data d => d -> Homo Int+ weightedShapeOf = ghom (+) (const 1)++</pre>++We can also use it to preserve choice values.+<p>+Let's run some tests.+<p>+[Apologies that the examples aren't very good, but they at least demonstrate usage.]++<!--red>NOTE TO SELF : Use test2, not test1!!!....</red-->+<pre>++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")+-- ((()(())())()()) -- with [Char] as a stop type, so String is treated as atomic++test_list = [[1,2],[3],[4,5,6::Int]]+-- ((()(()()))((()())((()(()(()())))())))++-----------------------------------------------++> showHomo $ shapeOf test_list+ +()+| ()+| | ()+| | ()+| | | ()+| | | ()+| ()+| | ()+| | | ()+| | | ()+| | ()+| | | ()+| | | | ()+| | | | ()+| | | | | ()+| | | | | ()+| | | | | | ()+| | | | | | ()+| | | ()++> showAsParens $ shapeOf test_list+ +((()(()()))((()())((()(()(()())))())))++> showAsParensBool $ ghom (mkQ False (odd::Int->Bool)) test_list+ +(.(.(*)(.(.)(.)))(.(.(*)(.))(.(.(.)(.(*)(.(.)(.))))(.))))++> showAsParensEnriched $ ghom (mkQ False (odd::Int->Bool)) test_list+ +(False(False(True)(False(False)(False)))(False(False(True)(False))(False(False(False)(False(True)(False(False)(False))))(False))))++> showHomo $ ghom (mkQ False (odd::Int->Bool)) test_list+ +False+| False+| | True+| | False+| | | False+| | | False+| False+| | False+| | | True+| | | False+| | False+| | | False+| | | | False+| | | | False+| | | | | True+| | | | | False+| | | | | | False+| | | | | | False+| | | False++> showHomo $ filterHomo id $ ghom (mkQ False (odd::Int->Bool)) test_list+ +False+| True+| True+| True++> showHetero $ ghomDyn test_list+ +[[1,2],[3],[4,5,6]]+ [1,2]+ 1+ [2]+ 2+ []+ [[3],[4,5,6]]+ [3]+ 3+ []+ [[4,5,6]]+ [4,5,6]+ 4+ [5,6]+ 5+ [6]+ 6+ []+ []++> showHetero $ filterHetero (/=(3::Int)) $ ghomDyn test_list+ +[[1,2],[3],[4,5,6]]+ 1+ 2+ 4+ 5+ 6++> showBi $ heteroToBi False (odd::Int->Bool) $ ghomDyn test_list+ +([[1,2],[3],[4,5,6]], False)+ ([1,2], False)+ (1, True)+ ([2], False)+ (2, False)+ ([], False)+ ([[3],[4,5,6]], False)+ ([3], False)+ (3, True)+ ([], False)+ ([[4,5,6]], False)+ ([4,5,6], False)+ (4, False)+ ([5,6], False)+ (5, True)+ ([6], False)+ (6, False)+ ([], False)+ ([], False)++> showBi $ ghomBi (mkQ False (odd::Int->Bool)) test_list+ +([[1,2],[3],[4,5,6]], False)+ ([1,2], False)+ (1, True)+ ([2], False)+ (2, False)+ ([], False)+ ([[3],[4,5,6]], False)+ ([3], False)+ (3, True)+ ([], False)+ ([[4,5,6]], False)+ ([4,5,6], False)+ (4, False)+ ([5,6], False)+ (5, True)+ ([6], False)+ (6, False)+ ([], False)+ ([], False)++> showBi $ filterBi id $ ghomBi (mkQ False (odd::Int->Bool)) test_list+ +([[1,2],[3],[4,5,6]], False)+ (1, True)+ (3, True)+ (5, True)++> showHomo $ biToHomo $ filterBi id $ ghomBi (mkQ False (odd::Int->Bool)) test_list+ +False+| True+| True+| True++> let f (x::Int) = if odd x then Just x else Nothing++> showHomo $ ghom (mkQ Nothing f) test_list+ +Nothing+| Nothing+| | Just 1+| | Nothing+| | | Nothing+| | | Nothing+| Nothing+| | Nothing+| | | Just 3+| | | Nothing+| | Nothing+| | | Nothing+| | | | Nothing+| | | | Nothing+| | | | | Just 5+| | | | | Nothing+| | | | | | Nothing+| | | | | | Nothing+| | | Nothing++> showHomo $ filterHomoMM $ ghom (mkQ Nothing f) test_list+ +Nothing+| Just 1+| Nothing+| | Just 3+| | Just 5++> showHomo $ unliftHomoM 0 $ filterHomoMM $ ghom (mkQ Nothing f) test_list+ +0+| 1+| 0+| | 3+| | 5++> showAsParens $ shapeOf exprAB+ +((())()(()))++> showAsParens $ shapeOf exprCD+ +(((()(()())))((()(()())))((()(()()))))++> showAsParens $ shapeOf exprEF+ +((()())(((()(()(()()))))(()(()(()())))))++> show $ ( ( unGhomDyn $ ghomDyn exprEF ) :: TE )+ +E2 (2,5) (F (E1 "foo") "bar")++> showHomo $ ( gempty exprEF :: BiM Int)+ +(<<TE>>,Nothing)+| (<<(Int,Int)>>,Nothing)+| | (<<Int>>,Nothing)+| | (<<Int>>,Nothing)+| (<<TF>>,Nothing)+| | (<<TE>>,Nothing)+| | | (<<[Char]>>,Nothing)+| | | | (<<Char>>,Nothing)+| | | | (<<[Char]>>,Nothing)+| | | | | (<<Char>>,Nothing)+| | | | | (<<[Char]>>,Nothing)+| | | | | | (<<Char>>,Nothing)+| | | | | | (<<[Char]>>,Nothing)+| | (<<[Char]>>,Nothing)+| | | (<<Char>>,Nothing)+| | | (<<[Char]>>,Nothing)+| | | | (<<Char>>,Nothing)+| | | | (<<[Char]>>,Nothing)+| | | | | (<<Char>>,Nothing)+| | | | | (<<[Char]>>,Nothing)+++Progressive refinement and accumulation:++> (showHomo $+ ( grefine+ (\ x -> case x of { E2 (y,z) _ -> Just (z+3)+ ; _ -> Nothing })+ ( gempty exprEF :: BiM Int)+ )+ )++(<<TE>>,Just 8)+| (<<(Int,Int)>>,Nothing)+| | (<<Int>>,Nothing)+| | (<<Int>>,Nothing)+| (<<TF>>,Nothing)+| | (<<TE>>,Nothing)+| | | (<<[Char]>>,Nothing)+| | | | (<<Char>>,Nothing)+| | | | (<<[Char]>>,Nothing)+| | | | | (<<Char>>,Nothing)+| | | | | (<<[Char]>>,Nothing)+| | | | | | (<<Char>>,Nothing)+| | | | | | (<<[Char]>>,Nothing)+| | (<<[Char]>>,Nothing)+| | | (<<Char>>,Nothing)+| | | (<<[Char]>>,Nothing)+| | | | (<<Char>>,Nothing)+| | | | (<<[Char]>>,Nothing)+| | | | | (<<Char>>,Nothing)+| | | | | (<<[Char]>>,Nothing)++> (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)+ )+ )+ )++(<<TE>>,Just 8)+| (<<(Int,Int)>>,Nothing)+| | (<<Int>>,Nothing)+| | (<<Int>>,Nothing)+| (<<TF>>,Nothing)+| | (<<TE>>,Just 3)+| | | (<<[Char]>>,Nothing)+| | | | (<<Char>>,Nothing)+| | | | (<<[Char]>>,Nothing)+| | | | | (<<Char>>,Nothing)+| | | | | (<<[Char]>>,Nothing)+| | | | | | (<<Char>>,Nothing)+| | | | | | (<<[Char]>>,Nothing)+| | (<<[Char]>>,Nothing)+| | | (<<Char>>,Nothing)+| | | (<<[Char]>>,Nothing)+| | | | (<<Char>>,Nothing)+| | | | (<<[Char]>>,Nothing)+| | | | | (<<Char>>,Nothing)+| | | | | (<<[Char]>>,Nothing)+++Testing that a Dynamic node can recover nodes elided below it:++Testing a chain of types:++> let (f::TH->Bool) x = case x of { H _ -> False ; _ -> True }++> show exprGHI++G (H I)++> showBi $ ghomBi (mkQ True f) exprGHI++(<<TG>>, True)+ (<<TH>>, False)+ (<<TI>>, True)++> showBi $ filterBi id $ ghomBi (mkQ True f) exprGHI++(<<TG>>, True)+ (<<TI>>, True)++> ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True f) exprGHI ) :: TG ) )++G (H I)++Testing a chain of constructors:++> show exprJ++J1 (J2 (J3 J))++> let (f::TJ->Bool) x = case x of { J1 _ -> False ; J3 _ -> False; _ -> True }++> showBi $ ghomBi (mkQ True f) exprJ++(<<TJ>>, False)+ (<<TJ>>, True)+ (<<TJ>>, False)+ (<<TJ>>, True)++> showBi $ filterBi id $ ghomBi (mkQ True f) exprJ++(<<TJ>>, False)+ (<<TJ>>, True)+ (<<TJ>>, True)++> ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True f) exprJ ) :: TJ ) )++J1 (J2 (J3 J))++Testing a mixture of types and constructors:++> show exprKLM++K2 (M1 (L2 L1) (L2 (L3 (M2 K3))))++> let (f::TL->Bool) x = case x of { L2 _ -> False ; L3 _ -> False; _ -> True }++> showBi $ ghomBi (mkQ True f) exprKLM++(<<TK>>, True)+ (<<TM>>, True)+ (<<TL>>, False)+ (<<TL>>, True)+ (<<TL>>, False)+ (<<TL>>, False)+ (<<TM>>, True)+ (<<TK>>, True)++> showBi $ filterBi id $ ghomBi (mkQ True f) exprKLM++(<<TK>>, True)+ (<<TM>>, True)+ (<<TL>>, True)+ (<<TM>>, True)+ (<<TK>>, True)++> ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True f) exprKLM ) :: TK ) )++K2 (M1 (L2 L1) (L2 (L3 (M2 K3))))+++Testing filterHomoM and filterBiM:++> show test_list++[[1,2],[3],[4,5,6]]++> showHomo $ filterHomoM odd $ ghom (mkQ 0 (id::Int->Int)) test_list++Nothing+| Just 1+| Nothing+| | Just 3+| | Just 5++> showBi $ filterBiM odd $ ghomBi (mkQ 0 (id::Int->Int)) test_list++([[1,2],[3],[4,5,6]], Nothing)+ (1, Just 1)+ ([[3],[4,5,6]], Nothing)+ (3, Just 3)+ (5, Just 5)+++Testing abstract datatype:++> show exprN++fromList [("",1.1),("pdsfhp",3.3),("sfv",2.2)]++> show $ Map.toList exprN++[("",1.1),("pdsfhp",3.3),("sfv",2.2)]++> showHomo $ shapeOf exprN++()+| ()+| | ()+| | | ()+| | | ()+| | ()+| | | ()+| | | | ()+| | | | | ()+| | | | | ()+| | | | | | ()+| | | | | | ()+| | | | | | | ()+| | | | | | | ()+| | | | | | | | ()+| | | | | | | | ()+| | | | | | | | | ()+| | | | | | | | | ()+| | | | | | | | | | ()+| | | | | | | | | | ()+| | | | ()+| | | ()+| | | | ()+| | | | | ()+| | | | | | ()+| | | | | | ()+| | | | | | | ()+| | | | | | | ()+| | | | | | | | ()+| | | | | | | | ()+| | | | | ()+| | | | ()++> showAsParensEnriched $ shapeOf exprN++(()(()(()(())(()))(()(()(()(())(()(())(()(())(()(())(()(())(()(())(())))))))(()))(()(()(()(())(()(())(()(())(()))))(()))(())))))++> showHomo $ ghom (mkQ 0.0 (\ (x::Float) -> x)) exprN++0.0+| 0.0+| | 0.0+| | | 0.0+| | | 1.1+| | 0.0+| | | 0.0+| | | | 0.0+| | | | | 0.0+| | | | | 0.0+| | | | | | 0.0+| | | | | | 0.0+| | | | | | | 0.0+| | | | | | | 0.0+| | | | | | | | 0.0+| | | | | | | | 0.0+| | | | | | | | | 0.0+| | | | | | | | | 0.0+| | | | | | | | | | 0.0+| | | | | | | | | | 0.0+| | | | 3.3+| | | 0.0+| | | | 0.0+| | | | | 0.0+| | | | | | 0.0+| | | | | | 0.0+| | | | | | | 0.0+| | | | | | | 0.0+| | | | | | | | 0.0+| | | | | | | | 0.0+| | | | | 2.2+| | | | 0.0++> showHomo $ filterHomo (>0.5) $ ghom (mkQ 0.0 (\ (x::Float) -> x)) exprN++0.0+| 1.1+| 3.3+| 2.2++> showHomo $ filterHomoM (>0.5) $ ghom (mkQ 0.0 (\ (x::Float) -> x)) exprN++Nothing+| Nothing+| | Just 1.1+| | Nothing+| | | Just 3.3+| | | Just 2.2++</pre>++<br>+I have also tested this on GHC parse trees (the motivating problem), and it works fine, but there is a catch.+These results are <a href="ghc.html">reported here</a>.++<p>+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.++<p>+Future work will include:+<ul>+<li>Implementing a true <tt>ghomP</tt> which prunes during generic traversal, using a fully generic stop condition (one pesky compiler error about a missing Typeable instance remains...). This would complement <tt>filterHomo</tt>, which acts post-mapping. The current <tt>ghomP'</tt> is a hack which gives you pruning, but only over the target values (i.e. post-mapped).+<li>I forget the second one...+<li>Would like to implement in Uniplate as well. Also in TH, if that's possible, just to get some experience with these.+</ul>+<p style="font-size: 11pt;">+Andrew Seniuk+<br>+June 12, 2014+<br>+<tt>rasfar@gmail.com</tt>+</small>++</body>+</html>+
+ HTML/style.css view
@@ -0,0 +1,3 @@+pre { margin-left: 20px; padding-left: 10px; padding-right: 10px; background-color: #DDD; }+tt { padding-left: 5px; padding-right: 5px; font-size: 11pt; background-color: #EEE; }+red { color: #f00; }
+ HTML/test-code.html view
@@ -0,0 +1,21 @@++<!DOCTYPE html>+<html>+<head>+<title>Generic shapeOf, and more General Homomorphisms - The Test</title>+<link rel="stylesheet" href="style.css" />+</head>+<body>++<h2>Test Code</h2>++<pre>++<red>Needs fresh.</red>++</pre>++<br><br><br><br>++</head>+</html>
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ sai-shape-syb.cabal view
@@ -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 <http://www.fremissant.net/shape-syb>+ 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+
+ src/SAI/Data/Generics/Shape.hs view
@@ -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 <http://www.fremissant.net/shape-syb>+-- 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+
+ src/SAI/Data/Generics/Shape/SYB.hs view
@@ -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 <http://www.fremissant.net/shape-syb>+-- 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 :: ...++-------------------------------------------------------------------------------+
+ src/SAI/Data/Generics/Shape/SYB/Filter.hs view
@@ -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 <http://www.fremissant.net/shape-syb>+-- 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++-------------------------------------------------------------------------------+
+ src/SAI/Data/Generics/Shape/SYB/GHC.hs view
@@ -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 <http://www.fremissant.net/shape-syb>+-- 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++-------------------------------------------------------------------------------+
+ tests/Main.hs view
@@ -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+
+ tests/ShapeSyb.hs view
@@ -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 = ()++-------------------------------------------------------------------------------+
+ tests/test-01.hs view
@@ -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!+
+ tests/test-02.hs view
@@ -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!+
+ tests/test-03.hs view
@@ -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+
+ tests/test-04.hs view
@@ -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)++-----------------------------------+
+ tests/test-05.hs view
@@ -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 ()+