diff --git a/HTML/ghc.html b/HTML/ghc.html
--- a/HTML/ghc.html
+++ b/HTML/ghc.html
@@ -13,21 +13,21 @@
SYB works by attempting type-safe cast, which triggers these holes.
We need a "staged" version of ghom (at least).
The HaRe source contains a good model of this (its GhcUtils.hs module).
-Using that I made ghomStaged
+Using that I made ghom_Staged
- -- (Note: this is now ghomStagedK in the API.)
- ghomStaged :: forall r d. Data d =>
- SYB.Stage
- -> r
- -> (r -> r -> r)
- -> GenericQ r
- -> d
- -> Homo r
- ghomStaged stage z k f x
+ -- (Note: this is now ghomK_Staged in the API.)
+ ghom_Staged :: forall r d. Data d =>
+ SYB.Stage
+ -> r
+ -> (r -> r -> r)
+ -> GenericQ r
+ -> d
+ -> Homo r
+ ghom_Staged stage z k f x
| checkItemStage stage x = z'
- | otherwise = foldl k' b (gmapQ (ghomStaged stage z k f) x)
+ | otherwise = foldl k' b (gmapQ (ghom_Staged stage z k f) x)
where
b = R (f x) []
z' = R z []
@@ -36,7 +36,7 @@
checkItemStage is from HaRe and can be found in the
-download.
+download.
Note also you will need to have ghc-syb-utils installed for these experiments.
@@ -62,30 +62,32 @@
-liftIO $ putStrLn $ showAsParens $ shapeOfStaged typechecked
+liftIO $ putStrLn $ showAsParens $ shapeOf_Staged typechecked
-(((*((*(*(**)))(*(*(**)))((**(((((*)((*)(*)))((*)((*)(*))))(*))(((((*))((*)))
-((*)))((((*))((*)))((*)))))(*))*)*(((*((**)*(((*(((*(*))((*(((*(*))((*(*))*))
-*(*((*)((*)*)))))*))*(((*(((*((*((*((((*))((*)))(*)))(*(*))))((*))((*))(**)))
-*)(*((((*(*)))(((*((*(*))(*((((*))((*)))(*)))(**)(*(((*)*((*((((*))((*)))(*))
-)(*((*(**)))))(*)))))))*))*))))((*(((*((*(*))((*))((*))(**)))*)(*((((*((*(*))
-(*((((*))((*)))(*)))(**)(*(((*)*((*((((*))((*)))(*)))(*((*(**)))))(*)))))))((
-(*(*)))*))*))))*))*)))*)((*)((*((*)((*)*)))(*((*)((*)*))))))***))*))))((*((*(
-*(**)))(*(*(**)))((**(((((*)((*)(*)))((*)((*)(*))))(*))(((((*))((*)))((*)))((
-((*))((*)))((*)))))(*))*)*(((*((**)*(((*(((*((**)***(*)(*((*)*))))((*(*))*))*
-(((*(*(*(*))))*)*)))((*(((*((*((**)***((*(*))(*(*)))(*((*)*))))))((*(*))*))*(
-((*(*(*((*((*(*))(*(*))))(*((*((*((*((((((*))((*)))((*)))((((*))((*)))((*))))
-(*)))(*(*))))(*(*))))))))))*)*)))*))((*((*)*))((*((*)((*)*)))(*((*)((*)*)))))
-)***))*))))((*(**((***(*))*)*(((*((**)*(((*(**(((*(*(*((*(((*((**)((**)*))))(
-*)))(*((*((*((*((((((*))((*)))((*)))((((**))((**)))((**))))(*)))(*(((((*))((*
-*)))(*))((*(((*)*((*((((*))((**)))(*)))(*((*(**)))))(**))))(*(((*)*((*((((*))
-((**)))(*)))(*((*(**)))))(**)))))))))(*((((*((*(((*)*((*))(**))))(*(*)))))(((
-*((*(((*)*((*))(**))))(*(*)))))*))*))))))))))*)*)))*)(*((*((**)((**)*)))*)))*
-**))*))))*))))
+(((•(•((•(•(••)))(•(•(••)))((••(((((•)((•)(•)))((•)((•)(•))))(•))(((((•))((•)
+))((•)))((((•))((•)))((•)))))(•))•)•(((•(•((••)•(((•(((•(•))((•(((•(•))((•(•)
+)•))•(•((•)((•)•)))))•))•(((•(((•((•((•(•))(•((•((((•))((•)))(•)))(•(•))))))(
+(•))((•))(••)))•)(•((((•(•)))(((•((•(•))(•((((•))((•)))(•)))(••)(•(((•)•((•(•
+))(•((•((((•))((•)))(•)))(•((•(••)))))))(•)))))))•))•))))((•(((•((•(•))((•))(
+(•))(••)))•)(•((((•((•(•))(•((((•))((•)))(•)))(••)(•(((•)•((•(•))(•((•((((•))
+((•)))(•)))(•((•(••)))))))(•)))))))(((•(•)))•))•))))•))•)))•)((•)((•((•)((•)•
+)))•))(•((•)((•)•))))•••)))•)))))((•(•((•(•(••)))(•(•(••)))((••(((((•)((•)(•)
+))((•)((•)(•))))(•))(((((•))((•)))((•)))((((•))((•)))((•)))))(•))•)•(((•(•((•
+•)•(((•(((•((••)•••(•)(•((•)•))•))((•(•))•))•(((•(•(•(•))))•)•)))((•(((•((•((
+••)•••((•(•))(•(•)))(•((•)•))•))))((•(•))•))•(((•(•(•((•(•))(•((•((•(•))(•((•
+(•))(•(•))))))(•((•((•(•))(•((•((•(•))(•((•((((((•))((•)))((•)))((((•))((•)))
+((•))))(•)))(•(•))))))(•(•))))))))))))))•)•)))•))((•((•)•))((•((•)((•)•)))•))
+(•((•)((•)•))))•••)))•)))))((•(•(••((•••(•))•)•(((•(•((••)•(((•(••(((•(•(•((•
+(•))(•((•(((•((••)((••)•))))(•)))(•((•((•(•))(•((•((•(•))(•((•((((((•))((•)))
+((•)))((((••))((••)))((••))))(•)))(•(((((•))((••)))(•))•((•(((•)•((•(•))(•((•
+((((•))((••)))(•)))(•((•(••)))))))(••))))(•(((•)•((•(•))(•((•((((•))((••)))(•
+)))(•((•(••)))))))(••)))))))))))(•((((•((•(((•)•((•))(••))))(•(•)))))(((•((•(
+((•)•((•))(••))))(•(•)))))•))•))))))))))))))•)•)))•)•(•((•((••)((••)•)))•)))•
+••)))•)))))•))))
-And this page shows the result of weightedShapeOfStaged applied to the staged GHC AST. These prove that our staged version works.
+And this page shows the result of weightedShapeOf_Staged applied to the staged GHC AST. These prove that our staged version works.
Note that you do get a runtime error if you use weightedShapeOf (the unstaged version).
@@ -114,7 +116,7 @@
-let xxx = weightedShapeOfStaged TypeChecker typechecked
+let xxx = weightedShapeOf_Staged TypeChecker typechecked
liftIO $ putStrLn $ show $ filterHomo (>=5) xxx
842
@@ -389,7 +391,7 @@
-let xxx = weightedShapeOfStaged TypeChecker typechecked
+let xxx = weightedShapeOf_Staged TypeChecker typechecked
liftIO $ putStrLn $ show $ filterHomo (>=50) xxx
842
diff --git a/HTML/ghc1.html b/HTML/ghc1.html
--- a/HTML/ghc1.html
+++ b/HTML/ghc1.html
@@ -24,447 +24,518 @@
-This is the usual way to show the GHC AST
+This is the usual way to show the GHC (7.8.1) AST
(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
+({abstract:Bag((Origin,(GenLocated SrcSpan (HsBindLR Var Var))))}
+ [
+ ((,)
+ (FromSource)
+ (L {A06.hs:(14,3)-(15,44)}
+ (AbsBinds
+ [{Var: a},{Var: t},{Var: t}]
+ [{Var: $dNum_a1bS},{Var: $dNum_a1bT},{Var: $dIntegral_a1bU}]
+ [
+ (ABE {Var: A06.tick} {Var: tick}
(WpCompose
(WpCompose
- (WpTyLam {Var: a})
(WpCompose
- (WpTyLam {Var: t})
- (WpTyLam {Var: t})))
+ (WpCompose
+ (WpTyLam {Var: a})
+ (WpCompose
+ (WpTyLam {Var: t})
+ (WpTyLam {Var: t})))
+ (WpCompose
+ (WpEvLam {Var: $dNum_a1bZ})
+ (WpCompose
+ (WpEvLam {Var: $dNum_a1c0})
+ (WpEvLam {Var: $dIntegral_a1c1}))))
+ (WpLet
+ ({abstract:TcEvBinds})))
(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
- [
+ (WpCompose
+ (WpEvApp
+ (EvId {Var: $dIntegral_a1c8}))
+ (WpEvApp
+ (EvId {Var: $dNum_a1c7})))
+ (WpEvApp
+ (EvId {Var: $dNum_a1c6})))
+ (WpCompose
+ (WpCompose
+ (WpTyApp t)
+ (WpTyApp t))
+ (WpTyApp a))))
+ (SpecPrags
+ []))]
+ ({abstract:TcEvBinds})
+ ({abstract:Bag((Origin,(GenLocated SrcSpan (HsBindLR Var Var))))}
+ [
+ ((,)
+ (FromSource)
(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
+ (FunBind
+ (L {A06.hs:14:3-6} {Var: tick})
+ (False)
+ (MG
[
- (L {A06.hs:14:19-44}
- (GRHS
+ (L {A06.hs:(14,3)-(15,44)}
+ (Match
[
- (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>}
+ (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}
+ (BodyStmt
+ (L {A06.hs:14:21-26}
+ (HsApp
+ (L {<no location info>}
+ (HsVar {Var: GHC.Num.fromInteger}))
+ (L {<no location info>}
+ (HsApp
+ (L {A06.hs:14:21-24}
+ (HsWrap
+ (WpCompose
+ (WpEvApp
+ (EvId {Var: $dIntegral_a1bC}))
+ (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}))
+ (EvId {Var: $dNum_a1bG}))
(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>}
+ (HsVar {Var: GHC.Num.+}))) {Fixity: infixl 6}
+ (L {A06.hs:14:43}
+ (HsOverLit
+ (OverLit
+ (HsIntegral
+ (1))
+ (False)
+ (HsApp
+ (L {<no location info>}
+ (HsVar {Var: GHC.Num.fromInteger}))
+ (L {<no location info>}
+ (HsApp
+ (L {<no location info>}
+ (HsWrap
+ (WpCompose
+ (WpEvApp
+ (EvId {Var: $dNum_a1bI}))
+ (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}
+ (BodyStmt
+ (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}))
+ (EvId {Var: $dNum_a1bK}))
(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
+ (HsVar {Var: GHC.Num.+}))) {Fixity: infixl 6}
+ (L {A06.hs:15:39}
+ (HsOverLit
+ (OverLit
+ (HsIntegral
+ (1))
+ (False)
+ (HsApp
+ (L {<no location info>}
+ (HsVar {Var: GHC.Num.fromInteger}))
+ (L {<no location info>}
+ (HsApp
+ (L {<no location info>}
+ (HsWrap
+ (WpCompose
+ (WpEvApp
+ (EvId {Var: $dNum_a1bM}))
+ (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))))])))),
+ ((,)
+ (FromSource)
+ (L {A06.hs:(11,3)-(12,30)}
+ (AbsBinds
+ [{Var: a},{Var: t},{Var: t}]
+ [{Var: $dNum_a1cy},{Var: $dNum_a1cz},{Var: $dIntegral_a1cA}]
+ [
+ (ABE {Var: A06.f} {Var: f}
(WpCompose
(WpCompose
- (WpTyLam {Var: a})
(WpCompose
- (WpTyLam {Var: t})
- (WpTyLam {Var: t})))
+ (WpCompose
+ (WpTyLam {Var: a})
+ (WpCompose
+ (WpTyLam {Var: t})
+ (WpTyLam {Var: t})))
+ (WpCompose
+ (WpEvLam {Var: $dNum_a1cF})
+ (WpCompose
+ (WpEvLam {Var: $dNum_a1cG})
+ (WpEvLam {Var: $dIntegral_a1cH}))))
+ (WpLet
+ ({abstract:TcEvBinds})))
(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
+ (WpCompose
+ (WpEvApp
+ (EvId {Var: $dIntegral_a1cO}))
+ (WpEvApp
+ (EvId {Var: $dNum_a1cN})))
+ (WpEvApp
+ (EvId {Var: $dNum_a1cM})))
+ (WpCompose
+ (WpCompose
+ (WpTyApp t)
+ (WpTyApp t))
+ (WpTyApp a))))
+ (SpecPrags
+ []))]
+ ({abstract:TcEvBinds})
+ ({abstract:Bag((Origin,(GenLocated SrcSpan (HsBindLR Var Var))))}
+ [
+ ((,)
+ (FromSource)
+ (L {A06.hs:(11,3)-(12,30)}
+ (FunBind
+ (L {A06.hs:11:3} {Var: f})
+ (False)
+ (MG
[
- (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}
+ (L {A06.hs:11:3-16}
+ (Match
+ [
+ (L {A06.hs:11:5-6}
+ (ConPatOut
+ (L {A06.hs:11:5-6}
+ ({abstract:ConLike}))
+ []
+ []
+ ({abstract:TcEvBinds})
+ (PrefixCon
+ []) [a]
+ (WpHole))),
+ (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}
+ ({abstract:ConLike}))
+ []
+ []
+ ({abstract:TcEvBinds})
+ (InfixCon
+ (L {A06.hs:12:6}
+ (VarPat {Var: x}))
+ (L {A06.hs:12:8-9}
+ (VarPat {Var: xs}))) [a]
+ (WpHole))))),
+ (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:22-27}
+ (L {<no location info>}
+ (HsVar {Var: GHC.Num.fromInteger}))
+ (L {<no location info>}
(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:12:16-19}
+ (HsApp
+ (L {<no location info>}
+ (HsVar {Var: GHC.Num.fromInteger}))
+ (L {<no location info>}
+ (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 {<no location info>}
+ (HsVar {Var: GHC.Num.fromInteger}))
+ (L {<no location info>}
+ (HsApp
+ (L {A06.hs:12:22-27}
+ (HsApp
+ (L {<no location info>}
+ (HsVar {Var: GHC.Num.fromInteger}))
+ (L {<no location info>}
+ (HsApp
+ (L {A06.hs:12:22-25}
+ (HsWrap
+ (WpCompose
+ (WpCompose
+ (WpCompose
+ (WpEvApp
+ (EvId {Var: $dIntegral_a1cs}))
+ (WpEvApp
+ (EvId {Var: $dNum_a1cr})))
+ (WpEvApp
+ (EvId {Var: $dNum_a1cq})))
+ (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))))])))),
+ ((,)
+ (FromSource)
+ (L {A06.hs:9:3-55}
+ (AbsBinds
+ []
+ []
+ [
+ (ABE {Var: A06.main} {Var: main}
+ (WpHole)
+ (SpecPrags
+ []))]
+ ({abstract:TcEvBinds})
+ ({abstract:Bag((Origin,(GenLocated SrcSpan (HsBindLR Var Var))))}
+ [
+ ((,)
+ (FromSource)
(L {A06.hs:9:3-55}
- (Match
- []
- (Nothing)
- (GRHSs
+ (FunBind
+ (L {A06.hs:9:3-6} {Var: main})
+ (False)
+ (MG
[
- (L {A06.hs:9:10-55}
- (GRHS
+ (L {A06.hs:9:3-55}
+ (Match
[]
- (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}
+ (Nothing)
+ (GRHSs
+ [
+ (L {A06.hs:9:10-55}
+ (GRHS
+ []
+ (L {A06.hs:9:10-55}
(HsApp
- (L {A06.hs:9:20-33}
+ (L {<no location info>}
+ (HsVar {Var: GHC.Num.fromInteger}))
+ (L {<no location info>}
(HsApp
- (L {A06.hs:9:20}
+ (L {A06.hs:9:10-17}
(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)))]}))]}
+ (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 {<no location info>}
+ (HsVar {Var: GHC.Num.fromInteger}))
+ (L {<no location info>}
+ (HsApp
+ (L {A06.hs:9:20-33}
+ (HsApp
+ (L {<no location info>}
+ (HsVar {Var: GHC.Num.fromInteger}))
+ (L {<no location info>}
+ (HsApp
+ (L {A06.hs:9:20}
+ (HsWrap
+ (WpCompose
+ (WpCompose
+ (WpCompose
+ (WpEvApp
+ (EvId {Var: $dIntegral_a1d5}))
+ (WpEvApp
+ (EvId {Var: $dNum_a1d4})))
+ (WpEvApp
+ (EvId {Var: $dNum_a1d3})))
+ (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_a1da}))
+ (WpTyApp GHC.Integer.Type.Integer))
+ (HsVar {Var: GHC.Enum.enumFromTo}))
+ (Nothing)
+ (FromTo
+ (L {A06.hs:9:23}
+ (HsOverLit
+ (OverLit
+ (HsIntegral
+ (1))
+ (False)
+ (HsApp
+ (L {<no location info>}
+ (HsVar {Var: GHC.Num.fromInteger}))
+ (L {<no location info>}
+ (HsApp
+ (L {<no location info>}
+ (HsWrap
+ (WpCompose
+ (WpEvApp
+ (EvId {Var: $dNum_a1d7}))
+ (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>}
+ (HsVar {Var: GHC.Num.fromInteger}))
+ (L {<no location info>}
+ (HsApp
+ (L {<no location info>}
+ (HsWrap
+ (WpCompose
+ (WpEvApp
+ (EvId {Var: $dNum_a1d9}))
+ (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))))]))))])
diff --git a/HTML/ghc2.html b/HTML/ghc2.html
--- a/HTML/ghc2.html
+++ b/HTML/ghc2.html
@@ -14,849 +14,950 @@
-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
+liftIO $ putStrLn $ show $ weightedShapeOf_Staged TypeChecker typechecked
+
+ 987
+ 404
+ 1
+ 402
+ 1
+ 400
+ 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
+ 333
+ 332
+ 330
+ 1
+ 328
+ 1
+ 326
+ 3
+ 1
+ 1
+ 1
+ 318
+ 294
+ 292
+ 1
+ 290
+ 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
+ 257
+ 255
+ 137
+ 1
+ 135
+ 62
+ 60
+ 1
+ 58
+ 26
+ 1
+ 24
+ 4
+ 1
+ 2
+ 1
+ 19
+ 1
+ 17
+ 12
+ 1
+ 10
+ 7
+ 3
+ 2
+ 1
+ 3
+ 2
+ 1
+ 2
+ 1
+ 4
+ 1
+ 2
+ 1
+ 14
+ 13
+ 12
+ 14
+ 13
+ 12
+ 3
+ 1
+ 1
+ 1
+ 72
+ 1
+ 70
+ 68
+ 5
+ 4
+ 1
+ 2
+ 1
+ 62
+ 60
+ 59
+ 1
+ 57
+ 4
+ 1
+ 2
+ 1
+ 12
+ 1
+ 10
+ 7
+ 3
+ 2
+ 1
+ 3
+ 2
+ 1
+ 2
+ 1
+ 3
+ 1
+ 1
+ 37
+ 1
+ 35
+ 34
+ 2
+ 1
+ 1
+ 28
+ 4
+ 1
+ 2
+ 1
+ 23
+ 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
+ 117
+ 115
+ 1
+ 113
+ 40
+ 38
+ 1
+ 36
+ 4
+ 1
+ 2
+ 1
+ 14
+ 13
+ 12
+ 14
+ 13
+ 12
+ 3
+ 1
+ 1
+ 1
+ 72
+ 1
+ 70
+ 68
+ 60
+ 59
+ 1
+ 57
+ 4
+ 1
+ 2
+ 1
+ 12
+ 1
+ 10
+ 7
+ 3
+ 2
+ 1
+ 3
+ 2
+ 1
+ 2
+ 1
+ 3
+ 1
+ 1
+ 37
+ 1
+ 35
+ 34
+ 2
+ 1
+ 1
+ 28
+ 4
+ 1
+ 2
+ 1
+ 23
+ 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
+ 14
+ 2
+ 1
+ 11
+ 9
+ 1
+ 7
+ 2
+ 1
+ 4
+ 2
+ 1
+ 1
+ 1
+ 9
+ 1
+ 7
+ 2
+ 1
+ 4
+ 2
+ 1
+ 1
+ 1
+ 1
+ 1
+ 1
+ 582
+ 292
+ 1
+ 290
+ 1
+ 288
+ 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
+ 221
+ 220
+ 218
+ 1
+ 216
+ 1
+ 214
+ 3
+ 1
+ 1
+ 1
+ 206
+ 178
+ 41
+ 1
+ 39
+ 25
+ 18
+ 1
+ 16
+ 3
+ 1
+ 1
+ 1
+ 1
+ 1
+ 2
+ 1
+ 6
+ 1
+ 4
+ 2
+ 1
+ 1
+ 1
+ 6
+ 4
+ 1
+ 2
+ 1
+ 1
+ 1
+ 12
+ 10
+ 8
+ 1
+ 6
+ 1
+ 4
+ 1
+ 2
+ 1
+ 1
+ 1
+ 136
+ 134
+ 1
+ 132
+ 35
+ 28
+ 1
+ 26
+ 25
+ 1
+ 23
+ 3
+ 1
+ 1
+ 1
+ 1
+ 1
+ 9
+ 4
+ 1
+ 2
+ 1
+ 4
+ 1
+ 2
+ 1
+ 6
+ 1
+ 4
+ 2
+ 1
+ 1
+ 1
+ 6
+ 4
+ 1
+ 2
+ 1
+ 1
+ 1
+ 95
+ 93
+ 91
+ 1
+ 89
+ 1
+ 87
+ 1
+ 85
+ 4
+ 1
+ 2
+ 1
+ 80
+ 1
+ 78
+ 18
+ 1
+ 16
+ 4
+ 1
+ 2
+ 1
+ 11
+ 1
+ 9
+ 4
+ 1
+ 2
+ 1
+ 4
+ 1
+ 2
+ 1
+ 59
+ 1
+ 57
+ 56
+ 1
+ 54
+ 4
+ 1
+ 2
+ 1
+ 49
+ 1
+ 47
+ 42
+ 1
+ 40
+ 4
+ 1
+ 2
+ 1
+ 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
+ 18
+ 6
+ 1
+ 4
+ 2
+ 1
+ 1
+ 11
+ 9
+ 1
+ 7
+ 2
+ 1
+ 4
+ 2
+ 1
+ 1
+ 1
+ 9
+ 1
+ 7
+ 2
+ 1
+ 4
+ 2
+ 1
+ 1
+ 1
+ 1
+ 1
+ 1
+ 289
+ 287
+ 1
+ 285
+ 1
+ 283
+ 1
+ 1
+ 8
+ 6
+ 1
+ 1
+ 1
+ 2
+ 1
+ 1
+ 1
+ 271
+ 270
+ 268
+ 1
+ 266
+ 1
+ 264
+ 3
+ 1
+ 1
+ 1
+ 256
+ 239
+ 237
+ 1
+ 235
+ 1
+ 1
+ 232
+ 230
+ 228
+ 1
+ 226
+ 1
+ 224
+ 1
+ 222
+ 4
+ 1
+ 2
+ 1
+ 217
+ 1
+ 215
+ 17
+ 1
+ 15
+ 12
+ 11
+ 1
+ 9
+ 3
+ 1
+ 1
+ 5
+ 3
+ 1
+ 1
+ 1
+ 2
+ 1
+ 197
+ 1
+ 195
+ 194
+ 1
+ 192
+ 4
+ 1
+ 2
+ 1
+ 187
+ 1
+ 185
+ 135
+ 1
+ 133
+ 4
+ 1
+ 2
+ 1
+ 128
+ 1
+ 126
+ 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
+ 94
+ 1
+ 92
+ 11
+ 8
+ 3
+ 2
+ 1
+ 4
+ 3
+ 1
+ 1
+ 2
+ 1
+ 1
+ 79
+ 39
+ 1
+ 37
+ 36
+ 2
+ 1
+ 1
+ 29
+ 4
+ 1
+ 2
+ 1
+ 24
+ 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
+ 39
+ 1
+ 37
+ 36
+ 2
+ 1
+ 1
+ 29
+ 4
+ 1
+ 2
+ 1
+ 24
+ 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
+ 1
+ 15
+ 1
+ 13
+ 11
+ 1
+ 9
+ 3
+ 1
+ 1
+ 5
+ 3
+ 1
+ 1
+ 1
+ 1
+ 1
+ 1
+ 1
+ 1
1
diff --git a/HTML/index.html b/HTML/index.html
--- a/HTML/index.html
+++ b/HTML/index.html
@@ -5,9 +5,9 @@
-
+
diff --git a/HTML/sai-shape-syb.html b/HTML/sai-shape-syb.html
--- a/HTML/sai-shape-syb.html
+++ b/HTML/sai-shape-syb.html
@@ -8,7 +8,7 @@
Download
-Here's
full source (BSD3-licensed, Cabal sdist) for:
+Here's
full source (BSD3-licensed, Cabal sdist) for:
- building the library (providing Data.Generics.Shape.{SYB, SYB.Filter, SYB.GHC}), and
- building the testbench corresponding to the examples in this post.
@@ -65,7 +65,7 @@
-with the constant-valued ("parentheses langauge") representation obtained for
+with the "parentheses langauge" representation obtained for the unit type
a ~ ().
@@ -144,26 +144,56 @@
-data TA = A1 | A2 TB TA TB
-data TB = B TA
-exprAB = A2 (B A1) A1 (B A1)
--- ((*)*(*))
+> showAsParens (shapeOf (1,2,3))
+
+(•••) 4 nodes
-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)))
--- (((*(**)))((*(**)))((*(**))))
+> showAsParens (shapeOf [1,2,3])
+
+(•(•(••))) 7 nodes
-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
+> showAsParensEnriched $ ghom (mkQ 0 (id::Int->Int)) [1,2,3])
+
+(0(1)(0(2)(0(3)(0))))
-test_list = [[1,2],[3],[4,5,6::Int]]
--- ((*(**))((**)((*(*(**)))*)))
+> showAsParensEnrichedWhen (>0) $ ghom (mkQ 0 (id::Int->Int)) [1,2,3])
+
+(.(1)(.(2)(.(3)(.))))
------------------------------------------------
+> showAsParensEnrichedM $ ghom (mkQ Nothing ((\x->Just x)::Int->Maybe Int)) [1,2,3]
+
+(1(2(3.)))
+
+Possibly, [[Int]], although polytypic, was not a good type for so many examples.
+(Some examples with ADTs come after.)
+
+> show test_list
+
+[[1,2],[3],[4,5,6]]
+
+> 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
+ []
+ []
+
> showHomo $ shapeOf test_list
()
@@ -188,16 +218,29 @@
> showAsParens $ shapeOf test_list
-((*(**))((**)((*(*(**)))*)))
+((•(••))((••)((•(•(••)))•)))
+> showAsParensEnriched $ weightedShapeOf test_list
+
+(19(5(1)(3(1)(1)))(13(3(1)(1))(9(7(1)(5(1)(3(1)(1))))(1))))
+
> showAsParensBool $ ghom (mkQ False (odd::Int->Bool)) test_list
-(.(.(*)(.(.)(.)))(.(.(*)(.))(.(.(.)(.(*)(.(.)(.))))(.))))
+(.(.(•)(.(.)(.)))(.(.(•)(.))(.(.(.)(.(•)(.(.)(.))))(.))))
+The parentheses around the leaves are not strictly needed,
+but the result would be harder to read:
+
+(.(.•(...))(.(.•.)(.(..(.•(...))).)))
+
> 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))))
+> showAsParensEnrichedWhen id $ ghom (mkQ False (odd::Int->Bool)) test_list
+
+(.(.(True)(.(.)(.)))(.(.(True)(.))(.(.(.)(.(True)(.(.)(.))))(.))))
+
> showHomo $ ghom (mkQ False (odd::Int->Bool)) test_list
False
@@ -220,6 +263,50 @@
| | | | | | False
| | | False
+> showHomoWhen id $ ghom (mkQ False (odd::Int->Bool)) test_list
+
+.
+| .
+| | True
+| | .
+| | | .
+| | | .
+| .
+| | .
+| | | True
+| | | .
+| | .
+| | | .
+| | | | .
+| | | | .
+| | | | | True
+| | | | | .
+| | | | | | .
+| | | | | | .
+| | | .
+
+> showHomoWhen (>0) $ ghom (mkQ 0 (id::Int->Int)) test_list
+
+.
+| .
+| | 1
+| | .
+| | | 2
+| | | .
+| .
+| | .
+| | | 3
+| | | .
+| | .
+| | | .
+| | | | 4
+| | | | .
+| | | | | 5
+| | | | | .
+| | | | | | 6
+| | | | | | .
+| | | .
+
> showHomo $ filterHomo id $ ghom (mkQ False (odd::Int->Bool)) test_list
False
@@ -227,6 +314,66 @@
| True
| True
+> showHomo $ filterHomoM id $ ghom (mkQ False (odd::Int->Bool)) test_list
+
+Nothing
+| Just True
+| Nothing
+| | Just True
+| | Just True
+
+> showHomo $ filterHomoM odd $ ghom (mkQ 0 (id::Int->Int)) test_list
+
+Nothing
+| Just 1
+| Nothing
+| | Just 3
+| | Just 5
+
+> showHomo $ filterHomo (>0) $ ghom (mkQ 0 (id::Int->Int)) test_list
+
+0
+| 1
+| 2
+| 3
+| 4
+| 5
+| 6
+
+> showHomo $ filterHomoM (>0) $ ghom (mkQ 0 (id::Int->Int)) test_list
+
+Nothing
+| Nothing
+| | Just 1
+| | Just 2
+| Nothing
+| | Just 3
+| | Nothing
+| | | Just 4
+| | | Nothing
+| | | | Just 5
+| | | | Just 6
+
+> showHomo $ filterHomoM (>=0) $ ghom (mkQ (-1) (id::Int->Int) `extQ` ((\_->0)::[Int]->Int)) test_list
+
+Nothing
+| Just 0
+| | Just 1
+| | Just 0
+| | | Just 2
+| | | Just 0
+| Nothing
+| | Just 0
+| | | Just 3
+| | | Just 0
+| | Just 0
+| | | Just 4
+| | | Just 0
+| | | | Just 5
+| | | | Just 0
+| | | | | Just 6
+| | | | | Just 0
+
> showHetero $ ghomDyn test_list
[[1,2],[3],[4,5,6]]
@@ -260,54 +407,54 @@
> 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)
+(<<[[Int]]>>,False)
+| (<<[Int]>>,False)
+| | (<<Int>>,True)
+| | (<<[Int]>>,False)
+| | | (<<Int>>,False)
+| | | (<<[Int]>>,False)
+| (<<[[Int]]>>,False)
+| | (<<[Int]>>,False)
+| | | (<<Int>>,True)
+| | | (<<[Int]>>,False)
+| | (<<[[Int]]>>,False)
+| | | (<<[Int]>>,False)
+| | | | (<<Int>>,False)
+| | | | (<<[Int]>>,False)
+| | | | | (<<Int>>,True)
+| | | | | (<<[Int]>>,False)
+| | | | | | (<<Int>>,False)
+| | | | | | (<<[Int]>>,False)
+| | | (<<[[Int]]>>,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)
+(<<[[Int]]>>,False)
+| (<<[Int]>>,False)
+| | (<<Int>>,True)
+| | (<<[Int]>>,False)
+| | | (<<Int>>,False)
+| | | (<<[Int]>>,False)
+| (<<[[Int]]>>,False)
+| | (<<[Int]>>,False)
+| | | (<<Int>>,True)
+| | | (<<[Int]>>,False)
+| | (<<[[Int]]>>,False)
+| | | (<<[Int]>>,False)
+| | | | (<<Int>>,False)
+| | | | (<<[Int]>>,False)
+| | | | | (<<Int>>,True)
+| | | | | (<<[Int]>>,False)
+| | | | | | (<<Int>>,False)
+| | | | | | (<<[Int]>>,False)
+| | | (<<[[Int]]>>,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)
+(<<[[Int]]>>,False)
+| (<<Int>>,True)
+| (<<Int>>,True)
+| (<<Int>>,True)
> showHomo $ biToHomo $ filterBi id $ ghomBi (mkQ False (odd::Int->Bool)) test_list
@@ -356,18 +503,40 @@
| | 3
| | 5
+-------------------------------------------------------
+
+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")
+
> showAsParens $ shapeOf exprAB
-((*)*(*))
+((•)•(•))
> showAsParens $ shapeOf exprCD
-(((*(**)))((*(**)))((*(**))))
+(((•(••)))((•(••)))((•(••))))
> showAsParens $ shapeOf exprEF
-((**)(((*(*(**))))(*(*(**)))))
+((••)(((•(•(••))))(•(•(••)))))
+> showAsParens $ shapeOf_ exprEF
+
+((••)((•)•))
+
+> showAsParensEnriched $ weightedShapeOf_ exprEF
+
+(12(3(1)(1))(8(4(3))(3)))
+
> show $ ( ( unGhomDyn $ ghomDyn exprEF ) :: TE )
E2 (2,5) (F (E1 "foo") "bar")
@@ -398,7 +567,7 @@
Progressive refinement and accumulation:
-> (showHomo $
+> (showBi $
( grefine
(\ x -> case x of { E2 (y,z) _ -> Just (z+3)
; _ -> Nothing })
@@ -427,7 +596,7 @@
| | | | | (<<Char>>,Nothing)
| | | | | (<<[Char]>>,Nothing)
-> (showHomo $
+> (showBi $
( gaccum
((\r1 r2 -> r1+r2) :: Int -> Int -> Int)
(\ x -> case x of { E1 s -> Just (length s)
@@ -462,109 +631,123 @@
| | | | | (<<[Char]>>,Nothing)
-Testing that a Dynamic node can recover nodes elided below it:
+Testing filterHomoM and filterBiM:
-Testing a chain of types:
+> show test_list
-> let (f::TH->Bool) x = case x of { H _ -> False ; _ -> True }
+[[1,2],[3],[4,5,6]]
-> show exprGHI
+> showHomo $ filterHomoM odd $ ghom (mkQ 0 (id::Int->Int)) test_list
-G (H I)
+Nothing
+| Just 1
+| Nothing
+| | Just 3
+| | Just 5
-> showBi $ ghomBi (mkQ True f) exprGHI
+> showBi $ filterBiM odd $ ghomBi (mkQ 0 (id::Int->Int)) test_list
-(<<TG>>, True)
- (<<TH>>, False)
- (<<TI>>, True)
+(<<[[Int]]>>,Nothing)
+| (<<Int>>,Just 1)
+| (<<[[Int]]>>,Nothing)
+| | (<<Int>>,Just 3)
+| | (<<Int>>,Just 5)
-> 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
+Testing abstract datatype:
-K2 (M1 (L2 L1) (L2 (L3 (M2 K3))))
+> show exprN
-> let (f::TL->Bool) x = case x of { L2 _ -> False ; L3 _ -> False; _ -> True }
+fromList [("",1.1),("pdsfhp",3.3),("sfv",2.2)]
-> showBi $ ghomBi (mkQ True f) exprKLM
+> show $ Map.toList exprN
-(<<TK>>, True)
- (<<TM>>, True)
- (<<TL>>, False)
- (<<TL>>, True)
- (<<TL>>, False)
- (<<TL>>, False)
- (<<TM>>, True)
- (<<TK>>, True)
+[("",1.1),("pdsfhp",3.3),("sfv",2.2)]
-> showBi $ filterBi id $ ghomBi (mkQ True f) exprKLM
+> showHomo $ shapeOf_ exprN
-(<<TK>>, True)
- (<<TM>>, True)
- (<<TL>>, True)
- (<<TM>>, True)
- (<<TK>>, True)
+()
+| ()
+| | ()
+| | | ()
+| | | ()
+| | ()
+| | | ()
+| | | | ()
+| | | | ()
+| | | ()
+| | | | ()
+| | | | | ()
+| | | | | ()
+| | | | ()
-> ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True f) exprKLM ) :: TK ) )
+> showHomoWhen (>0) $ ghomP (mkQ False (\ (_::String) -> True)) (mkQ 0 (\ (x::Float) -> x) `extQ` (\ (_::String) -> 0)) exprN
-K2 (M1 (L2 L1) (L2 (L3 (M2 K3))))
+.
+| .
+| | .
+| | | .
+| | | 1.1
+| | .
+| | | .
+| | | | .
+| | | | 3.3
+| | | .
+| | | | .
+| | | | | .
+| | | | | 2.2
+| | | | .
+> showHomoWhen (>0) $ ghom (mkQ 0 (\ (x::Float) -> x)) exprN
-Testing filterHomoM and filterBiM:
+.
+| .
+| | .
+| | | .
+| | | 1.1
+| | .
+| | | .
+| | | | .
+| | | | | .
+| | | | | .
+| | | | | | .
+| | | | | | .
+| | | | | | | .
+| | | | | | | .
+| | | | | | | | .
+| | | | | | | | .
+| | | | | | | | | .
+| | | | | | | | | .
+| | | | | | | | | | .
+| | | | | | | | | | .
+| | | | 3.3
+| | | .
+| | | | .
+| | | | | .
+| | | | | | .
+| | | | | | .
+| | | | | | | .
+| | | | | | | .
+| | | | | | | | .
+| | | | | | | | .
+| | | | | 2.2
+| | | | .
-> show test_list
+> showHomo $ filterHomo (>0) $ ghom (mkQ 0 (\ (x::Float) -> x)) exprN
-[[1,2],[3],[4,5,6]]
+0.0
+| 1.1
+| 3.3
+| 2.2
-> showHomo $ filterHomoM odd $ ghom (mkQ 0 (id::Int->Int)) test_list
+> showHomo $ filterHomoM (>0) $ ghom (mkQ 0 (\ (x::Float) -> x)) exprN
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)
+| | Just 1.1
+| | Nothing
+| | | Just 3.3
+| | | Just 2.2
@@ -576,13 +759,6 @@
So, for what it's worth, I was able to implement the generic homomorphisms.
Probably this is already supported by some library, but I was unlucky in my search.
-
-Future work will include:
-
-- Implementing a true ghomP which prunes during generic traversal, using a fully generic stop condition (one pesky compiler error about a missing Typeable instance remains...). This would complement filterHomo, which acts post-mapping. The current ghomP' is a hack which gives you pruning, but only over the target values (i.e. post-mapped).
-
- I forget the second one...
-
- Would like to implement in Uniplate as well. Also in TH, if that's possible, just to get some experience with these.
-
Andrew Seniuk
diff --git a/sai-shape-syb.cabal b/sai-shape-syb.cabal
--- a/sai-shape-syb.cabal
+++ b/sai-shape-syb.cabal
@@ -1,17 +1,19 @@
name: sai-shape-syb
-version: 0.2.2
-synopsis: Obtain homogeneous values from arbitrary values, tramsforming or culling data
+version: 0.3.0
+synopsis: Obtain homogeneous values from arbitrary values, transforming or culling data
description:
This package provides SYB shape support: generic mapping to
homogeneous types, and related features. Complements existing
- Uniplate and TH shape libraries. See
- for more information.
+ Uniplate and TH shape libraries.
.
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@.
+ .
+ See the project
+ for more information.
license: BSD3
license-file: LICENSE
author: Andrew Seniuk
@@ -64,15 +66,9 @@
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
+ , ghc-syb-utils
if flag(USE_DATA_TREE)
build-depends: containers
hs-source-dirs: src
@@ -100,27 +96,11 @@
--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
+--other-extensions: TemplateHaskell
-- if flag(PROFILE)
-- ghc-options: -fprof-auto -auto-all -caf-all
-- if flag(OPTIMISE)
@@ -139,64 +119,15 @@
-- 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)
+ -- 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
+ , HUnit
hs-source-dirs: tests
default-language: Haskell2010
diff --git a/src/SAI/Data/Generics/Shape/SYB.hs b/src/SAI/Data/Generics/Shape/SYB.hs
--- a/src/SAI/Data/Generics/Shape/SYB.hs
+++ b/src/SAI/Data/Generics/Shape/SYB.hs
@@ -5,13 +5,10 @@
-------------------------------------------------------------------------------
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveFunctor #-}
-
{-# LANGUAGE DeriveDataTypeable #-}
-
-{- LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE Rank2Types #-}
-----------------------------------------------------------------------------
-- |
@@ -56,6 +53,8 @@
ghom ,
ghomK ,
+ ghomP ,
+ ghomE ,
ghomDyn ,
ghomBi ,
@@ -75,13 +74,8 @@
--
-- @'ghomBi' g = 'heteroToBi' g . 'biToHetero' . 'ghomBi' f@
-#if 1
biToHomo ,
biToHetero ,
-#else
- biToHomo_forgetful ,
- biToHetero_faithful ,
-#endif
heteroToBi ,
-- * Conversions concerning lifted types
@@ -95,22 +89,19 @@
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
+ shapeOf_ ,
sizeOf ,
symmorphic ,
(~~) ,
weightedShapeOf ,
+ weightedShapeOf_ ,
weightedRose ,
weightedRoseJust ,
@@ -130,11 +121,13 @@
--- | 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 ,
+ showHomoWhen ,
showHomoM ,
showAsParens ,
showAsParensBool ,
showAsParensEnriched ,
+ showAsParensEnrichedWhen ,
showAsParensEnrichedM ,
showDyn ,
@@ -177,7 +170,6 @@
-- 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
@@ -245,19 +237,25 @@
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 "| "
+ where show' n (Node r chs)
+ = indent n ++ show r ++ "\n" ++ concatMap (show' (1+n)) chs
+ where indent n = concat $ replicate n "| "
+ showHomoWhen :: Show r => (r -> Bool) -> Rose r -> String
+ showHomoWhen p = show' 0
+ where show' n (Node r chs)
+ = indent n ++ s ++ "\n" ++ concatMap (show' (1+n)) chs
+ where indent n = concat $ replicate n "| "
+ s = if p r then show r else "."
+
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 "| "
+ 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 "| "
-------------------------------------------------------------------------------
@@ -273,48 +271,66 @@
b = Node (f x) []
k (Node r chs) nod = Node r (chs++[nod])
- -- | Like ghom, but use a custom combining function, instead of
+ -- | 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
+ (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])
+ -- | Like 'ghom', but also filter branches using a generic predicate,
+ -- retaining the stop nodes. The @'GenericQ' r@ argument can be specialised
+ -- for the stop node type(s), for instance to summarise stop branches.
+ -- (See 'ghomE' for more flexibility.)
+ ghomP :: forall r s d. Data d =>
+ GenericQ Bool -- defines stop nodes
+ -> GenericQ r -- what to do with nodes (typically including a case for stop nodes)
+ -> d
+ -> Homo r
+ ghomP p f x
+ | p x = Node (f x) []
+ | otherwise = foldl k b (gmapQ (ghomP p f) x)
+ where
+ b = Node (f x) []
+ k (Node r chs) nod = Node r (chs++[nod])
+
+ -- | Like 'ghom', but also filter branches using a generic predicate,
+ -- retaining the stop nodes and summarising their branches in
+ -- 'Right' values; default values are placed in the non-stop, 'Left' nodes.
+ -- You can fmap your own function @(s -> r)@ to the result, then collapse
+ -- from @'Either' r r@ to @r@ in the obvious way. (The function 'ghomP' is
+ -- probably sufficient in most cases.)
+ ghomE :: forall r s d. Data d =>
+ GenericQ Bool -- defines stop nodes
+ -> GenericQ r -- Left : what to do with non-stop nodes
+ -> GenericQ s -- Right : what to do with stop nodes
+ -> d
+ -> Homo (Either r s)
+ ghomE p f f_stop x
+ | p x = Node (Right (f_stop x)) []
+ | otherwise = foldl k b (gmapQ (ghomE p f f_stop) x)
+ where
+ b = Node (Left (f x)) []
+ k (Node r chs) nod = Node 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
-------------------------------------------------------------------------------
@@ -326,7 +342,6 @@
-------------------------------------------------------------------------------
-#if 1
-- | Drops the 'Dynamic' component.
biToHomo :: Bi r -> Homo r
biToHomo (Node (_,r) chs) = Node r (map biToHomo chs)
@@ -334,17 +349,7 @@
-- | 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)
@@ -379,7 +384,6 @@
-- 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
@@ -402,20 +406,17 @@
-- | Compare two general polytypic values 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
+ -- | Operator for 'not . symmorphic'.
+ (/~) :: forall d1 d2. (Data d1,Data d2) => d1 -> d2 -> Bool
+ (/~) x y = not $ symmorphic x y
+--(/~) = not . symmorphic
+
-------------------------------------------------------------------------------
-- | Number of nodes in a rose tree.
@@ -424,15 +425,10 @@
-- | 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.
@@ -484,7 +480,7 @@
{-# INLINE unzip #-}
unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])
-}
- -- | Inverse of zipRose (up to Currying).
+ -- | Inverse of zipRose (up to currying).
#if 0
#elif 0
unzipRose :: Rose (r, s) -> (Rose r, Rose s)
@@ -532,8 +528,7 @@
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?!
+ chs' = map weightedRoseJust chs
n = sum $ map (\ (Node (_,m) _) -> m) chs'
-------------------------------------------------------------------------------
@@ -548,24 +543,78 @@
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])
-------------------------------------------------------------------------------
+ -- | Stop traversal on 'String's.
+ shapeOf_ :: forall d. Data d => d -> Shape
+ shapeOf_ x = ghomP pg fg x
+ where
+ pg :: forall d'. Data d' => d' -> Bool
+ pg = mkQ False p_String
+ p_String :: String -> Bool
+ p_String _ = True
+ fg :: forall d''. Data d'' => d'' -> ()
+ fg = const ()
+
+ -- | Stop traversal on 'String's, using the length of the string
+ -- as the weight for the node rooting the 'String'.
+ -- XXX Using 2*length + 1 would be more consistent?
+ weightedShapeOf_ :: forall d. Data d => d -> Homo Int
+ weightedShapeOf_ x = weightedRoseSpecial $ ghomP pg fg x
+ where
+ pg :: forall d'. Data d' => d' -> Bool
+ pg = mkQ False p_String
+ p_String :: String -> Bool
+ p_String x = True
+ fg :: forall d''. Data d'' => d'' -> Int
+ fg = mkQ 1 f_String
+ f_String :: String -> Int
+ f_String x = length x
+ weightedRoseSpecial :: Rose Int -> Rose Int
+ weightedRoseSpecial (Node r chs) = foldl k' b (map weightedRoseSpecial chs)
+ where
+ b = Node r []
+ k' (Node rw chs) nod@(Node rw' _) = Node (rw + rw') (chs++[nod])
+
+-------------------------------------------------------------------------------
+
+ -- | One-line, parentheses language representation of the shape of a @'Homo' r@.
showAsParens :: Homo r -> String
showAsParens (Node _ []) = "*"
showAsParens (Node _ chs) = "(" ++ concatMap showAsParens chs ++ ")"
+ -- | One-line, parentheses language representation of the shape of a 'Homo' 'Bool', enriched by symbols for 'True' (@*@) and 'False' (@.@).
+ --
+ -- (While parentheses around the leaves can in principle be omitted,
+ -- the loss in readability is not compensated by the shortening.)
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 ++ ")"
+ showAsParensBool (Node r chs)
+#if 0
+ | null chs = s -- if want to omit parentheses around leaves
+#endif
+ | otherwise = "(" ++ s ++ concatMap showAsParensBool chs ++ ")"
+ where s = if r then "*" else "."
+ -- | One-line, parentheses language representation of the shape of a @'Homo' r@, and nodes adorned with @'show' r@.
showAsParensEnriched :: Show r => Homo r -> String
- showAsParensEnriched (Node r chs) = "(" ++ show r ++ concatMap showAsParensEnriched chs ++ ")"
+ showAsParensEnriched nod@(Node r [])
+ | s == "()" = showAsParens nod where s = show r
+ showAsParensEnriched (Node r chs)
+ = "(" ++ show r ++ concatMap showAsParensEnriched chs ++ ")"
+ -- | One-line, parentheses language representation of the shape of a @'Homo' r@, and nodes adorned with @'show' r@ when the predicate holds (and with @.@ otherwise).
+ showAsParensEnrichedWhen :: Show r => (r -> Bool) -> Homo r -> String
+ showAsParensEnrichedWhen p (Node r chs)
+ = "(" ++ s ++ concatMap (showAsParensEnrichedWhen p) chs ++ ")"
+ where s = if p r then show r else "."
+
+ -- | One-line, parentheses language representation of the shape of a @'HomoM' r@, with 'Just' nodes designated by @'show' r@ (and 'Nothing' nodes by @.@).
showAsParensEnrichedM :: Show r => HomoM r -> String
+ showAsParensEnrichedM (Node Nothing []) = "."
+ showAsParensEnrichedM (Node (Just r) []) = show r
showAsParensEnrichedM (Node Nothing chs) = "(" ++ concatMap showAsParensEnrichedM chs ++ ")"
showAsParensEnrichedM (Node (Just r) chs) = "(" ++ show r ++ concatMap showAsParensEnrichedM chs ++ ")"
@@ -612,23 +661,30 @@
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
+ = indent n ++ showDyn d ++ "\n"
+ ++ concatMap (showHetero' (1+n)) chs
where
indent n = replicate (2*n) ' '
showBi :: Show r => Bi r -> String
+-- The space marked ---V is the only difference, but the space is preferable!
+#if 0
+ showBi = showHomo
+#else
showBi = showBi' 0
where
- showBi' n (Node (d,r) chs)
- = indent n ++ "(" ++ showDyn d ++ ", " ++ show r ++ ")" ++ "\n"
- ++ concatMap (showBi' (1+n)) chs
+ showBi' n (Node (d,r) chs) ---V
+ = indent n ++ "(" ++ showDyn d ++ ", " ++ show r ++ ")" ++ "\n"
+ ++ concatMap (showBi' (1+n)) chs
where
indent n = replicate (2*n) ' '
+#endif
-------------------------------------------------------------------------------
@@ -666,7 +722,6 @@
-- 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?...
@@ -679,17 +734,14 @@
-- 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.
+ --
+ -- XXX /Still only calls error, when should throw an exception./
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
+ fg = mkQ Nothing f
x' = grefine' x
where
--- grefine' ::
grefine' (Node (xd,mr) chs) = x'
where
x' = Node (xd,r') $ map grefine' chs
@@ -697,68 +749,27 @@
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
+ fg = mkQ Nothing f
x' = gaccum' x
where
--- gaccum' ::
gaccum' (Node (xd,mr) chs) = x'
where
md = fromDynamic xd :: Maybe d
r = fromJust mr
mr_ = fg $ fromJust md
r_ = fromJust mr_
-#if 0
-#elif 1
mr' | isNothing md = mr
| isNothing mr_ = mr
| isNothing mr = mr_
| otherwise = Just $ r `k` r_
-#elif 0
--- mr' | isNothing md = trace "*1*" $ Nothing -- why does this seem to stop recursion?
- mr' | isNothing md = trace "*1*" $ mr
- | isNothing mr_ = trace "*2*" $ mr
- | isNothing mr = trace "*3*" $ mr_
- | otherwise = trace "*4*" $ Just $ r `k` r_
-#elif 0
- mr' | isNothing md = Nothing
- | isNothing mr_ = Nothing
- | isNothing mr = mr_
- | otherwise = Just $ r `k` r_
-#endif
x' = Node (xd,mr') $ map gaccum' chs
-
---gassim :: ...
-------------------------------------------------------------------------------
diff --git a/src/SAI/Data/Generics/Shape/SYB/Filter.hs b/src/SAI/Data/Generics/Shape/SYB/Filter.hs
--- a/src/SAI/Data/Generics/Shape/SYB/Filter.hs
+++ b/src/SAI/Data/Generics/Shape/SYB/Filter.hs
@@ -46,7 +46,7 @@
--
-- and
--
- -- @type 'BiM' r = 'Bi' ('Maybe' r) = 'Homo' ('Dynamic', ('Maybe' r))@
+ -- @type 'BiM' r = 'Bi' ('Maybe' r) = 'Homo' ('Dynamic', 'Maybe' r)@
--
-- See "Shape.SYB" for other functions involving 'HomoM' and 'BiM'.
@@ -86,13 +86,11 @@
filterHomoM_ ,
filterHomoM_' ,
- -- * Experimental...
+ -- * Experimental, but sufficient for the task
gfilter ,
gfilter_ ,
- mkQP , -- XXX unfortunately the user must deal with this
-
- shapeOf_ ,
+ mkQP ,
) where
@@ -106,6 +104,8 @@
import Data.Generics.Aliases ( GenericQ )
import Data.Generics.Aliases ( mkQ )
import Data.Generics.Aliases ( extQ )
+ import Data.Generics.Aliases ( GenericT )
+ import Data.Data ( gmapT )
--import Data.Function ( fix )
import Data.Dynamic
--import Data.HList
@@ -120,10 +120,7 @@
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
@@ -131,15 +128,12 @@
-------------------------------------------------------------------------------
- filterHomo' :: (r -> Bool) -> Homo r -> Homo r
+ filterHomo' :: forall r. (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 :: Rose r -> [ Rose r ]
f c@(Node rc chsc)
| p rc = [c]
| otherwise = chsc'
@@ -147,9 +141,7 @@
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
@@ -166,22 +158,15 @@
| 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' :: forall r. (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 :: Bi r -> [ Bi r ]
f c@(Node (_,rc) chsc)
| p rc = [c]
| otherwise = chsc'
@@ -208,7 +193,7 @@
-- 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",
+ -- an 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!...
@@ -230,248 +215,22 @@
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')
@@ -480,31 +239,23 @@
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...
+ | null forest = error "filterHomoM_': null forest"
+ | [x] <- forest = x
+ | otherwise = Node rdflt forest
where
forest = filterHomoM_ x
-------------------------------------------------------------------------------
+ -- XXX So much cloned code here; how to do a single?
+
-- | Tolerate lifted nodes in the result, in exchange for
-- better structure preservation.
--
@@ -520,11 +271,8 @@
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!...
+ -- XXX Surely can do bottom-up and avoid iterating?
defuzz :: HomoM r -> HomoM r
defuzz (Node v chs) = Node v $ map defuzz chs'
where
@@ -532,8 +280,6 @@
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
@@ -549,10 +295,8 @@
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!...
+ -- XXX Surely can do bottom-up and avoid iterating?
defuzz :: BiM r -> BiM r
defuzz (Node v chs) = Node v $ map defuzz chs'
where
@@ -560,8 +304,6 @@
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
@@ -569,21 +311,15 @@
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!...
+ -- XXX Surely can do bottom-up and avoid iterating?
defuzz :: HomoM r -> HomoM r
defuzz (Node v chs) = Node v $ map defuzz chs'
where
@@ -591,59 +327,20 @@
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!...
+ -- XXX Surely can do bottom-up and avoid iterating?
defuzz :: BiM r -> BiM r
defuzz (Node v chs) = Node v $ map defuzz chs'
where
@@ -651,8 +348,6 @@
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
@@ -662,24 +357,82 @@
-------------------------------------------------------------------------------
- -- | 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
+ -- | Takes a generic query (create this with mkQP), and a value,
+ -- and produce the forest of trees comprised by Just nodes.
+ -- (Refer to 'filterHomoM_' for more details.)
+ gfilter :: forall r d. Data d =>
+ (forall d. (Data d, Typeable d) => d -> Maybe r)
+ -> d
+ -> [Homo r]
+ gfilter fmk x = filterHomoM_ $ ghom fmk x
+
+ -- | 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 =>
+ r
+ -> (forall d. (Data d, Typeable d) => d -> Maybe r)
+ -> d
+ -> Homo r
+ gfilter_ rdflt fmk x =
+ ( filterHomoM_' rdflt
+ $ ghom fmk x ) :: Homo r
+
+-------------------------------------------------------------------------------
+
+ -- | 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
-------------------------------------------------------------------------------
diff --git a/src/SAI/Data/Generics/Shape/SYB/GHC.hs b/src/SAI/Data/Generics/Shape/SYB/GHC.hs
--- a/src/SAI/Data/Generics/Shape/SYB/GHC.hs
+++ b/src/SAI/Data/Generics/Shape/SYB/GHC.hs
@@ -29,30 +29,38 @@
-- Once you have a @'Homo' r@, 'Hetero', or @'Bi' r@, the rest of
-- the API in "Shape.SYB" and "Shape.SYB.Filter" is applicable.
--
+-- Please refer to "Shape.SYB" for descriptions of these functions.
+-- Here, in addition to the extra 'SYB.Stage' argument, most of the
+-- @ghom@ combinator functions also take an extra argument of type @r@,
+-- the default value to use wherever staging holes are encountered.
+--
-----------------------------------------------------------------------------
module SAI.Data.Generics.Shape.SYB.GHC (
- -- * Staged shape functions
-
- ghomStaged ,
- ghomStagedK ,
- ghomDynStaged ,
- ghomBiStaged ,
-
- GHC_AST_HOLE ,
+-- (See comment below.)
+#if 0
+ Stage(..) ,
+-- GHC_AST_HOLE ,
+#endif
- shapeOfStaged ,
- shapeOfStaged_ ,
- sizeOfStaged ,
+ -- * Staged shape functions
- symmorphicStaged ,
+ ghom_Staged ,
+ ghomK_Staged ,
+ ghomP_Staged ,
+ ghomE_Staged ,
+ ghomDyn_Staged ,
+ ghomBi_Staged ,
- weightedShapeOfStaged ,
+ shapeOf_Staged ,
+ shapeOf_Staged_ ,
+ sizeOf_Staged ,
- -- * Re-exported from the ghc-syb-utils package
+ symmorphic_Staged ,
- Stage(..) ,
+ weightedShapeOf_Staged ,
+ weightedShapeOf_Staged_ ,
) where
@@ -71,6 +79,7 @@
#endif
import SAI.Data.Generics.Shape.SYB ( Homo, Shape, Hetero, Bi )
import SAI.Data.Generics.Shape.SYB ( zipRose )
+ import SAI.Data.Generics.Shape.SYB ( HomoM )
import SAI.Data.Generics.Shape.SYB.Filter ( filterHomoMM )
--import SAI.Data.Generics.Shape.SYB.Filter ( filterHomoM_' )
@@ -78,87 +87,158 @@
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 Data.Generics.Aliases ( mkQ )
+ import Data.Generics.Aliases ( extQ )
+
+ 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
+ import qualified GHC.SYB.Utils as SYB
+
-------------------------------------------------------------------------------
+#if 0
+-- Note: It works to do this (and then no ghc-syb-utils dependence
+-- for this project) ... but if try to use ghc-syb-utils by a
+-- project which also uses this, you run afoul!...
+ -- | 'Stage' is extracted from package, including the following comment.
+ --
+ -- "/GHC AST types tend to have undefined holes, to be filled by later compiler phases. We tag ASTs with their source, so that we can avoid such holes based on who generated the ASTs./"
+ data Stage = Parser | Renamer | TypeChecker deriving (Eq,Ord,Show)
+
newtype GHC_AST_HOLE = GHC_AST_HOLE Stage deriving ( Typeable )
+#else
+ newtype GHC_AST_HOLE = GHC_AST_HOLE SYB.Stage deriving ( Typeable )
+#endif
-------------------------------------------------------------------------------
- ghomStaged :: forall r d. Data d =>
- Stage
- -> r
- -> GenericQ r
- -> d
- -> Homo r
- ghomStaged stage z f x
+ ghom_Staged :: forall r d. Data d =>
+ SYB.Stage
+ -> r
+ -> GenericQ r
+ -> d
+ -> Homo r
+ ghom_Staged stage z f x
| checkItemStage stage x = z'
- | otherwise = foldl k b (gmapQ (ghomStaged stage z f) x)
+ | otherwise = foldl k b (gmapQ (ghom_Staged 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
+ ghomK_Staged :: forall r d. Data d =>
+ SYB.Stage
+ -> r
+ -> (r -> r -> r)
+ -> GenericQ r
+ -> d
+ -> Homo r
+ ghomK_Staged stage z k f x
| checkItemStage stage x = z'
- | otherwise = foldl k' b (gmapQ (ghomStagedK stage z k f) x)
+ | otherwise = foldl k' b (gmapQ (ghomK_Staged 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])
+ ghomP_Staged :: forall r s d. Data d =>
+ SYB.Stage
+ -> r -- default for holes
+ -> GenericQ Bool -- defines stop nodes
+ -> GenericQ r -- typically, specialised for stop nodes
+ -> d
+ -> Homo r
+ ghomP_Staged stage z p f x
+ | checkItemStage stage x = z'
+ | p x = Node (f x) []
+ | otherwise = foldl k b (gmapQ (ghomP_Staged stage z p f) x)
+ where
+ b = Node (f x) []
+ z' = Node z []
+ k (Node r chs) nod = Node r (chs++[nod])
+
+ ghomE_Staged :: forall r s d. Data d =>
+ SYB.Stage
+ -> r -- default for holes
+ -> GenericQ Bool -- defines stop nodes
+ -> GenericQ r -- Left : what to do with non-stop nodes
+ -> GenericQ s -- Right : what to do with stop nodes
+ -> d
+ -> Homo (Either r s)
+ ghomE_Staged stage z p f f_stop x
+ | checkItemStage stage x = z'
+ | p x = Node (Right (f_stop x)) []
+ | otherwise = foldl k b (gmapQ (ghomE_Staged stage z p f f_stop) x)
+ where
+ b = Node (Left (f x)) []
+ z' = Node (Left z) []
+ k (Node r chs) nod = Node r (chs++[nod])
+
-- | Uses "Data.Dynamic" to support mutiple types homogeneously.
- ghomDynStaged :: forall d. Data d => Stage -> d -> Hetero
- ghomDynStaged stage x
+ ghomDyn_Staged :: forall d. Data d => SYB.Stage -> d -> Hetero
+ ghomDyn_Staged stage x
| checkItemStage stage x = Node (toDyn $ GHC_AST_HOLE stage) []
- | otherwise = foldl k b (gmapQ (ghomDynStaged stage) x)
+ | otherwise = foldl k b (gmapQ (ghomDyn_Staged 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
+ -- | @'ghomBi_Staged' s f x = 'zipRose' ('ghomDyn_Staged' s x) ('ghom_Staged' s f x)@
+ ghomBi_Staged :: forall r d. Data d => SYB.Stage -> r -> GenericQ r -> d -> Bi r
+ ghomBi_Staged stage z f x = zipRose (ghomDyn_Staged stage x) $ ghom_Staged stage z f x
-------------------------------------------------------------------------------
- shapeOfStaged :: forall d. Data d => Stage -> d -> Shape
- shapeOfStaged stage = ghomStaged stage () (const ())
+ shapeOf_Staged :: forall d. Data d => SYB.Stage -> d -> Shape
+ shapeOf_Staged stage = ghom_Staged 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
+ -- | Treat 'String' and 'GHC.FastString' as atomic values.
+ shapeOf_Staged_ :: forall d. Data d => SYB.Stage -> d -> Shape
+ shapeOf_Staged_ stage x = ghomP_Staged stage () pg 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
+ pg :: forall d'. Data d' => d' -> Bool
+ pg = mkQ False p_String `extQ` p_FastString
+ p_String :: String -> Bool
+ p_String _ = True
+ p_FastString :: GHC.FastString -> Bool
+ p_FastString _ = True
+ fg :: forall d''. Data d'' => d'' -> ()
+ fg = const ()
- sizeOfStaged :: forall d. Data d => Stage -> d -> Int
- sizeOfStaged stage = sizeOfRose . (shapeOfStaged stage)
+ sizeOf_Staged :: forall d. Data d => SYB.Stage -> d -> Int
+ sizeOf_Staged stage = sizeOfRose . (shapeOf_Staged stage)
- weightedShapeOfStaged :: forall d. Data d => Stage -> d -> Homo Int
- weightedShapeOfStaged stage = ghomStagedK stage 1 (+) (const 1)
+ weightedShapeOf_Staged :: forall d. Data d => SYB.Stage -> d -> Homo Int
+ weightedShapeOf_Staged stage = ghomK_Staged stage 1 (+) (const 1)
+ -- | Treat 'String' and 'GHC.FastString' as atomic values.
+ weightedShapeOf_Staged_ :: forall d. Data d => SYB.Stage -> d -> Homo Int
+ weightedShapeOf_Staged_ stage x = weightedRoseSpecial $ ghomP_Staged stage 1 pg fg x
+ where
+ pg :: forall d'. Data d' => d' -> Bool
+ pg = mkQ False p_String `extQ` p_FastString
+ p_String :: String -> Bool
+ p_String _ = True
+ p_FastString :: GHC.FastString -> Bool
+ p_FastString _ = True
+ fg :: forall d''. Data d'' => d'' -> Int
+ fg = mkQ 1 f_String `extQ` f_FastString
+ f_String :: String -> Int
+ f_String x = length x
+ f_FastString :: GHC.FastString -> Int
+ f_FastString x = GHC.lengthFS x
+ weightedRoseSpecial :: Rose Int -> Rose Int
+ weightedRoseSpecial (Node r chs) = foldl k' b (map weightedRoseSpecial chs)
+ where
+ b = Node r []
+ k' (Node rw chs) nod@(Node rw' _) = Node (rw + rw') (chs++[nod])
+
-------------------------------------------------------------------------------
-- Borrowed from HaRe:
@@ -167,22 +247,22 @@
--- | Checks whether the current item is undesirable for analysis in the current
-- AST Stage.
- checkItemStage :: (Typeable a, Data a) => Stage -> a -> Bool
+ checkItemStage :: (Typeable a, Data a) => SYB.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 :: (Typeable a) => SYB.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
+ 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 :: Data a => SYB.Stage -> a -> Bool
checkItemStage2 stage x = (const False `SYB.ext1Q` hsWithBndrs) x
where
hsWithBndrs = const (stage < SYB.Renamer) :: GHC.HsWithBndrs a -> Bool
@@ -190,15 +270,15 @@
#if 0
checkItemRenamer :: (Data a, Typeable a) => a -> Bool
- checkItemRenamer x = checkItemStage SYB.Renamer x
+ checkItemRenamer x = checkItemStage Renamer x
#endif
-------------------------------------------------------------------------------
-- | Compare two GHC ASTs 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
+ symmorphic_Staged :: forall d1 d2. (Data d1,Data d2) =>
+ SYB.Stage -> d1 -> d2 -> Bool
+ symmorphic_Staged stage x y = shapeOf_Staged stage x == shapeOf_Staged stage y
-------------------------------------------------------------------------------
diff --git a/tests/ShapeSyb.hs b/tests/ShapeSyb.hs
--- a/tests/ShapeSyb.hs
+++ b/tests/ShapeSyb.hs
@@ -23,7 +23,7 @@
import Data.Data ( Data, Typeable )
import Data.Generics.Aliases ( mkQ, extQ )
import Data.Generics.Aliases ( GenericQ )
- import Data.List ( intersperse )
+ import Data.List ( intercalate )
import Control.Exception ( evaluate )
--import Data.Dynamic
@@ -138,6 +138,8 @@
f x = dud_result -- still needed! (notwithstanding mkQ)
-- f x = x
+#if 1
+
#if 0
--test1 :: TC -> Homo Result
@@ -173,7 +175,7 @@
-- 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?
+ -- generically-typed function f to be 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
@@ -240,6 +242,8 @@
p (Result (x,y)) = not $ x == 0 && y == 0
#endif
+#endif
+
test2 :: TC -> Homo Result
test2 = ghom ((const dud_result) `extQ` fTC `extQ` fTD)
where
@@ -327,28 +331,69 @@
-- artificial demand thus:
evaluate (test4 company1)
#endif
- putStrLn $ concat $ intersperse "\n" [ ""
+ putStrLn $ intercalate "\n" [ ""
+ , "> showAsParens (shapeOf (1,2,3))\n "
+ , let x = ((1,2,3)::(Int,Int,Int)) in showAsParens (shapeOf x) ++ " " ++ show (sizeOf x) ++ " nodes" ++ "\n"
+ , "> showAsParens (shapeOf [1,2,3])\n "
+ , showAsParens (shapeOf [1,2,3::Int]) ++ " " ++ show (sizeOf ([1,2,3::Int])) ++ " nodes" ++ "\n"
+ , "> showAsParensEnriched $ ghom (mkQ 0 (id::Int->Int)) [1,2,3])\n "
+ , (showAsParensEnriched $ ghom (mkQ 0 (id::Int->Int)) [1,2,3::Int]) ++ "\n"
+ , "> showAsParensEnrichedWhen (>0) $ ghom (mkQ 0 (id::Int->Int)) [1,2,3])\n "
+ , (showAsParensEnrichedWhen (>0) $ ghom (mkQ 0 (id::Int->Int)) [1,2,3::Int]) ++ "\n"
+ , "> showAsParensEnrichedM $ ghom (mkQ Nothing ((\\x->Just x)::Int->Maybe Int)) [1,2,3]\n "
+ , (showAsParensEnrichedM $ ghom (mkQ Nothing ((\x->Just x)::Int->Maybe Int)) [1,2,3::Int]) ++ "\n"
+
+ , "\nPossibly, [[Int]], although polytypic, was not a good type for so many examples."
+ , "(Some examples with ADTs come after.)\n"
, "> show test_list\n "
, show test_list ++ "\n"
+ , "> showHetero $ ghomDyn test_list\n "
+ , showHetero $ ghomDyn test_list
, "> showHomo $ shapeOf test_list\n "
, showHomo $ shapeOf test_list
, "> showAsParens $ shapeOf test_list\n "
, (showAsParens $ shapeOf test_list) ++ "\n"
+ , "> showAsParensEnriched $ weightedShapeOf test_list\n "
+ , (showAsParensEnriched $ weightedShapeOf test_list) ++ "\n"
, "> showAsParensBool $ ghom (mkQ False (odd::Int->Bool)) test_list\n "
, (showAsParensBool $ ghom (mkQ False (odd::Int->Bool)) test_list) ++ "\n"
+ , "The parentheses around the leaves are not strictly needed,"
+ , "but the result would be harder to read:"
+ , ""
+ , "(.(.*(...))(.(.*.)(.(..(.*(...))).)))"
+ , ""
, "> showAsParensEnriched $ ghom (mkQ False (odd::Int->Bool)) test_list\n "
, (showAsParensEnriched $ ghom (mkQ False (odd::Int->Bool)) test_list) ++ "\n"
+ , "> showAsParensEnrichedWhen id $ ghom (mkQ False (odd::Int->Bool)) test_list\n "
+ , (showAsParensEnrichedWhen id $ 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
+ , "> showHomoWhen id $ ghom (mkQ False (odd::Int->Bool)) test_list\n "
+ , showHomoWhen id $ ghom (mkQ False (odd::Int->Bool)) test_list
+ , "> showHomoWhen (>0) $ ghom (mkQ 0 (id::Int->Int)) test_list\n "
+ , showHomoWhen (>0) $ ghom (mkQ 0 (id::Int->Int)) 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
+ , "> showHomo $ filterHomoM id $ ghom (mkQ False (odd::Int->Bool)) test_list\n "
+ , showHomo $ filterHomoM id $ ghom (mkQ False (odd::Int->Bool)) test_list
+ , "> showHomo $ filterHomoM odd $ ghom (mkQ 0 (id::Int->Int)) test_list\n "
+ , showHomo $ filterHomoM odd $ ghom (mkQ 0 (id::Int->Int)) test_list
+ , "> showHomo $ filterHomo (>0) $ ghom (mkQ 0 (id::Int->Int)) test_list\n "
+ , showHomo $ filterHomo (>0) $ ghom (mkQ 0 (id::Int->Int)) test_list
+ , "> showHomo $ filterHomoM (>0) $ ghom (mkQ 0 (id::Int->Int)) test_list\n "
+ , showHomo $ filterHomoM (>0) $ ghom (mkQ 0 (id::Int->Int)) test_list
+ , "> showHomo $ filterHomoM (>=0) $ ghom (mkQ (-1) (id::Int->Int) `extQ` ((\\_->0)::[Int]->Int)) test_list\n "
+ , showHomo $ filterHomoM (>=0) $ ghom (mkQ (-1) (id::Int->Int) `extQ` ((\_->0)::[Int]->Int)) 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
+ , "or, equivalently\n"
+ , "> showBi $ ghomBi (mkQ False (odd::Int->Bool)) test_list\n "
+-- , showBi $ heteroToBi False (odd::Int->Bool) $ ghomDyn test_list
+ , showBi $ ghomBi (mkQ False (odd::Int->Bool)) test_list
#if 1
@@ -356,8 +401,6 @@
, "> 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 "
@@ -373,71 +416,61 @@
#endif
#if 1
+ , "\nTesting algebraic data types:\n"
+ , "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\")"
+ , ""
, "> showAsParens $ shapeOf exprAB\n "
, (showAsParens $ shapeOf exprAB) ++ "\n"
, "> showAsParens $ shapeOf exprCD\n "
, (showAsParens $ shapeOf exprCD) ++ "\n"
, "> showAsParens $ shapeOf exprEF\n "
, (showAsParens $ shapeOf exprEF) ++ "\n"
+ , "> showAsParens $ shapeOf_ exprEF -- String treated as atomic\n"
+ , (showAsParens $ shapeOf_ exprEF) ++ "\n"
+ , "> showAsParensEnriched $ weightedShapeOf_ exprEF\n "
+ , (showAsParensEnriched $ weightedShapeOf_ exprEF) ++ "\n"
#endif
+#if 1
+
, "> show $ ( ( unGhomDyn $ ghomDyn exprEF ) :: TE )\n "
, (show $ ( ( unGhomDyn $ ghomDyn exprEF ) :: TE ) ) ++ "\n"
- , "> showHomo $ ( gempty exprEF :: BiM Int)\n "
- , (showHomo $ ( gempty exprEF :: BiM Int)) ++ "\n"
+ , "> showHomo $ ( gempty exprEF :: BiM Int )\n "
+ , (showHomo $ ( gempty exprEF :: BiM Int )) ++ "\n"
, "Progressive refinement and accumulation:\n"
#if 1
, "\
-> (showHomo $\n\
+> (showBi $\n\
( grefine\n\
(\\ x -> case x of { E2 (y,z) _ -> Just (z+3)\n\
; _ -> Nothing })\n\
- ( gempty exprEF :: BiM Int)\n\
+ ( gempty exprEF :: BiM Int )\n\
)\n\
)\n"
#endif
- , (showHomo $
+ , (showBi $
( grefine
(\ x -> case x of { E2 (y,z) _ -> Just (z+3)
; _ -> Nothing })
- ( gempty exprEF :: BiM Int)
+ ( 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\
+> (showBi $\n\
( gaccum\n\
((\\r1 r2 -> r1+r2) :: Int -> Int -> Int)\n\
(\\ x -> case x of { E1 s -> Just (length s)\n\
@@ -445,12 +478,12 @@
( grefine\n\
(\\ x -> case x of { E2 (y,z) _ -> Just (z+3)\n\
; _ -> Nothing })\n\
- ( gempty exprEF :: BiM Int)\n\
+ ( gempty exprEF :: BiM Int )\n\
)\n\
)\n\
)\n"
#endif
- , (showHomo $
+ , (showBi $
( gaccum
((\r1 r2 -> r1+r2) :: Int -> Int -> Int)
(\ x -> case x of { E1 s -> Just (length s)
@@ -458,11 +491,12 @@
( grefine
(\ x -> case x of { E2 (y,z) _ -> Just (z+3)
; _ -> Nothing })
- ( gempty exprEF :: BiM Int)
+ ( gempty exprEF :: BiM Int )
)
)
)
+#if 0
, "\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"
@@ -496,6 +530,7 @@
, 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"
+#endif
, "\nTesting filterHomoM and filterBiM:\n"
, "> show test_list\n"
@@ -512,18 +547,25 @@
, show exprN ++ "\n"
, "> show $ Map.toList exprN\n"
, (show $ Map.toList exprN) ++ "\n"
+ , "> showHomo $ shapeOf_ exprN -- String treated as atomic\n"
+ , showHomo $ shapeOf_ exprN
, "> showHomo $ shapeOf exprN\n"
, showHomo $ shapeOf exprN
+#if 0
+-- Worse than futile...
, "> 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
+#endif
+ , "> showHomoWhen (>0) $ ghomP (mkQ False (\\ (_::String) -> True)) (mkQ 0 (\\ (x::Float) -> x) `extQ` (\\ (_::String) -> 0)) exprN\n"
+ , showHomoWhen (>0) $ ghomP (mkQ False (\ (_::String)->True)) (mkQ 0 (\ (x::Float) -> x) `extQ` (\ (_::String) -> 0)) exprN
+ , "> showHomoWhen (>0) $ ghom (mkQ 0 (\\ (x::Float) -> x)) exprN\n"
+ , showHomoWhen (>0) $ ghom (mkQ 0 (\ (x::Float) -> x)) exprN
+ , "> showHomo $ filterHomo (>0) $ ghom (mkQ 0 (\\ (x::Float) -> x)) exprN\n"
+ , showHomo $ filterHomo (>0) $ ghom (mkQ 0 (\ (x::Float) -> x)) exprN
+ , "> showHomo $ filterHomoM (>0) $ ghom (mkQ 0 (\\ (x::Float) -> x)) exprN\n"
+ , showHomo $ filterHomoM (>0) $ ghom (mkQ 0 (\ (x::Float) -> x)) exprN
-#if 0
+#if 1
, "show exprCD\n "
, show exprCD ++ "\n"
@@ -547,15 +589,17 @@
, "show company1\n "
, show company1 ++ "\n"
- , "showAsParens $ shapeOf company1\n "
- , (showAsParens $ shapeOf company1) ++ "\n"
- , "showHomo $ shapeOf company1\n "
- , showHomo $ shapeOf company1
+ , "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
diff --git a/tests/test-05.hs b/tests/test-05.hs
--- a/tests/test-05.hs
+++ b/tests/test-05.hs
@@ -1,22 +1,7 @@
--------------------------------------------------------------------------------
-
-{-# LANGUAGE CPP #-}
-
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-{- LANGUAGE NoMonomorphismRestriction #-}
-
-{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
-
--------------------------------------------------------------------------------
+ {-# LANGUAGE CPP #-}
module Main ( main ) where
-
--------------------------------------------------------------------------------
import ShapeSyb ( main_tests )
import Control.Monad ( void )