building the testbench corresponding to the examples in this post.
@@ -147,11 +147,11 @@
-> showAsParens (shapeOf (1,2,3))
+> showAsParens $ shapeOf (1,2,3)
(•••) 4 nodes
-> showAsParens (shapeOf [1,2,3])
+> showAsParens $ shapeOf [1,2,3]
(•(•(••))) 7 nodes
diff --git a/HTML/test-code.html b/HTML/test-code.html
--- a/HTML/test-code.html
+++ b/HTML/test-code.html
@@ -1,5 +1,4 @@
-
-
+
Generic shapeOf, and more General Homomorphisms - The Test
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright (c) 2014, Andrew Seniuk
+Copyright (c) 2014, Andrew G. Seniuk
All rights reserved.
@@ -13,7 +13,7 @@
disclaimer in the documentation and/or other materials provided
with the distribution.
- * Neither the name of Andrew Seniuk nor the names of other
+ * Neither the name of Andrew G. Seniuk nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
diff --git a/sai-shape-syb.cabal b/sai-shape-syb.cabal
--- a/sai-shape-syb.cabal
+++ b/sai-shape-syb.cabal
@@ -1,6 +1,6 @@
name: sai-shape-syb
-version: 0.3.3
+version: 0.3.4
synopsis: Obtain homogeneous values from arbitrary values, transforming or culling data
description:
This package provides SYB shape support: generic mapping to
@@ -10,15 +10,15 @@
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@.
+ a homogeneous type @ <# a>@, parameterised by any choice type @<# a>@.
.
See the project
for more information.
license: BSD3
license-file: LICENSE
-author: Andrew Seniuk
+author: Andrew G. Seniuk
maintainer: Andrew Seniuk
-homepage: http://www.fremissant.net/shape-syb
+homepage: http://fremissant.net/shape-syb
bug-reports: http://fremissant.net/shape-syb/trac
---bug-reports: Andrew Seniuk
category: Generics
@@ -64,9 +64,11 @@
-- other-extensions:
build-depends:
base == 4.*
- , syb <= 0.4.2
- , ghc >= 7.4 && < 7.9
--- , ghc-paths == 0.1.*
+ -- syb bounded above (<=0.4.2) by ghc-syb-utils ATT
+ , syb == 0.*
+ , ghc >= 7.4 && < 7.10
+ -- (tested with ghc-syb-utils-0.2.2, but probably
+ -- advisable to use the latest available version)
, ghc-syb-utils == 0.2.*
if flag(USE_DATA_TREE)
build-depends: containers == 0.5.*
@@ -119,9 +121,11 @@
, sai-shape-syb
- , syb <= 0.4.2
+ -- syb bounded above (<=0.4.2) by ghc-syb-utils ATT
+ , syb == 0.*
, ghc >= 7.4 && < 7.9
--- , ghc-paths == 0.1.*
+ -- (tested with ghc-syb-utils-0.2.2, but probably
+ -- advisable to use the latest available version)
, ghc-syb-utils == 0.2.*
-- XXX only for testing (to make a Data.Map)
, containers == 0.5.*
diff --git a/src/SAI/Data/Generics/Shape.hs b/src/SAI/Data/Generics/Shape.hs
--- a/src/SAI/Data/Generics/Shape.hs
+++ b/src/SAI/Data/Generics/Shape.hs
@@ -4,10 +4,10 @@
-----------------------------------------------------------------------------
-- |
-- Module : SAI.Data.Generics.Shape
--- Copyright : (c) Andrew Seniuk, 2014
+-- Copyright : Andrew G. Seniuk 2014-2015
-- License : BSD-style (see the LICENSE file)
--
--- Maintainer : rasfar@gmail.com
+-- Maintainer : Andrew Seniuk
-- Stability : experimental
-- Portability : non-portable (uses Data.Generics.Basics)
--
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
@@ -13,10 +13,10 @@
-----------------------------------------------------------------------------
-- |
-- Module : SAI.Data.Generics.Shape.SYB
--- Copyright : (c) Andrew Seniuk, 2014
+-- Copyright : Andrew G. Seniuk 2014-2015
-- License : BSD-style (see the LICENSE file)
--
--- Maintainer : rasfar@gmail.com
+-- Maintainer : Andrew Seniuk
-- Stability : experimental
-- Portability : non-portable (uses Data.Generics.Basics)
--
@@ -561,7 +561,8 @@
-- | 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?
+ --
+ -- /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
@@ -605,13 +606,13 @@
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).
+ -- | One-line, parentheses language representation of the shape of a @'Homo' r@, and nodes adorned with @'show' r@ when the predicate holds (and with a dot 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 @.@).
+ -- | One-line, parentheses language representation of the shape of a @'HomoM' r@, with 'Just' nodes designated by @'show' r@ (and 'Nothing' nodes by a dot).
showAsParensEnrichedM :: Show r => HomoM r -> String
showAsParensEnrichedM (Node Nothing []) = "."
showAsParensEnrichedM (Node (Just r) []) = show r
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
@@ -16,10 +16,10 @@
-----------------------------------------------------------------------------
-- |
-- Module : SAI.Data.Generics.Shape.SYB.Filter
--- Copyright : (c) Andrew Seniuk, 2014
+-- Copyright : Andrew G. Seniuk 2014-2015
-- License : BSD-style (see the LICENSE file)
--
--- Maintainer : rasfar@gmail.com
+-- Maintainer : Andrew Seniuk
-- Stability : experimental
-- Portability : non-portable (uses Data.Generics.Basics)
--
@@ -48,7 +48,7 @@
--
-- @type 'BiM' r = 'Bi' ('Maybe' r) = 'Homo' ('Dynamic', 'Maybe' r)@
--
- -- See "Shape.SYB" for other functions involving 'HomoM' and 'BiM'.
+ -- See for other functions involving 'HomoM' and 'BiM'.
filterHomoM ,
filterBiM ,
@@ -72,7 +72,7 @@
-- bottom-up or top-down would do it in one pass, but ... maybe I
-- did something wrong...)
--
- -- Other transformations are possible; see also 'filterHomoM_.
+ -- Other transformations are possible; see also 'filterHomoM_'.
filterHomo ,
filterHetero ,
@@ -357,8 +357,8 @@
-------------------------------------------------------------------------------
- -- | Takes a generic query (create this with mkQP), and a value,
- -- and produce the forest of trees comprised by Just nodes.
+ -- | Takes a generic query (create this with 'mkQP'), and a value,
+ -- and produce the forest of trees of 'Just' nodes.
-- (Refer to 'filterHomoM_' for more details.)
gfilter :: forall r d. Data d =>
(forall d. (Data d, Typeable d) => d -> Maybe r)
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
@@ -13,10 +13,10 @@
-----------------------------------------------------------------------------
-- |
-- Module : SAI.Data.Generics.Shape.SYB.GHC
--- Copyright : (c) Andrew Seniuk, 2014
+-- Copyright : Andrew G. Seniuk 2014-2015
-- License : BSD-style (see the LICENSE file)
---
--- Maintainer : rasfar@gmail.com
+--
+-- Maintainer : Andrew Seniuk
-- Stability : experimental
-- Portability : non-portable (uses Data.Generics.Basics)
--
@@ -27,9 +27,9 @@
--
-- The present module provides support for staged GHC AST types.
-- Once you have a @'Homo' r@, 'Hetero', or @'Bi' r@, the rest of
--- the API in "Shape.SYB" and "Shape.SYB.Filter" is applicable.
+-- the API in and is applicable.
--
--- Please refer to "Shape.SYB" for descriptions of these functions.
+-- Please refer to 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.
diff --git a/tests/Main.hs b/tests/Main.hs
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -36,7 +36,7 @@
if failures counts > 0
#if 1
then exitFailure
- else exitSuccess
+ else exitSuccess
#else
-- XXX Why is this saying "unexpected semicolons in source file"??
-- Template Haskell or something?...
diff --git a/tests/ShapeSyb.hs b/tests/ShapeSyb.hs
--- a/tests/ShapeSyb.hs
+++ b/tests/ShapeSyb.hs
@@ -264,6 +264,8 @@
---------------------------------------
+ -- (This data type is from the original SYB papers.)
+
data CompanyType = Company [DepartmentType]
data DepartmentType = Department String ManagerType [EmployeeType]
data ManagerType = Manager { rank :: Float
@@ -290,8 +292,8 @@
, nice_salary :: Int }
deriving ( Show )
- isNiceHole NiceHole = True
- isNiceHole _ = False
+ isNiceRecord NiceRecord{} = True
+ isNiceRecord _ = False
------------------------------
@@ -333,9 +335,9 @@
#endif
putStrLn $ intercalate "\n" [ ""
- , "> showAsParens (shapeOf (1,2,3))\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]\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"
@@ -593,19 +595,23 @@
, (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
+ , "showHomoWhen isNiceRecord $ test4 company1\n "
+ , showHomoWhen isNiceRecord $ test4 company1
+ -- , "showHomo $ test4 company1\n "
+ -- , showHomo $ test4 company1
+ , "showHomoWhen isNiceRecord $ filterHomo isNiceRecord $ test4 company1\n "
+ , showHomoWhen isNiceRecord $ filterHomo isNiceRecord $ test4 company1
+ -- , "showHomo $ filterHomo isNiceRecord $ test4 company1\n "
+ -- , showHomo $ filterHomo isNiceRecord $ test4 company1
+-- , showHomo $ filterHomo isNiceRecord $ shapeOf exprAB -- pointless
#endif
#endif
]
-#endif
return 0
+#endif
-------------------------------------------------------------------------------
diff --git a/tests/test-01.hs b/tests/test-01.hs
deleted file mode 100644
--- a/tests/test-01.hs
+++ /dev/null
@@ -1,49 +0,0 @@
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-
- module Main ( main ) where
-
- import SAI.Data.Generics.Shape.SYB ( Homo, ghom, shapeOf, weightedShapeOf )
---import SAI.Data.Generics.Shape.SYB ( Rose(..) )
- import Data.Data ( Data, Typeable )
---import Data.Data
- import Data.Generics.Aliases ( mkT )
- import Data.Generics.Schemes ( everywhere )
---import Data.Generics ( Generic )
---import Data.Tree ( Tree(..) )
-
-#if 1
- data TA = A1 | A2 TB TA TB deriving ( Data, Typeable )
- data TB = B TA deriving ( Data, Typeable )
- exprAB = A2 (B A1) A1 (B A1)
-#else
- data TA = A1 | A2 TB deriving ( Data, Typeable )
- data TB = B TA deriving ( Data, Typeable )
- exprAB = A2 (B (A2 (B A1)))
- data TA = A1 String | A2 (Int,Int) TB deriving ( Data, Typeable )
---instance Data TA
---instance Typeable TA
---instance Generic TA
- data TB = B TA String deriving ( Data, Typeable )
---instance Data TB
---instance Typeable TB
---instance Generic TB
---data TA = A1 String | A2 (Int,Int) TB deriving ( Data, Typeable )
---data TB = B TA String deriving ( Data, Typeable )
- exprAB = A2 (2,5) (B (A1 "foo") "bar")
-#endif
-
- main = putStrLn $ show $ shapeOf exprAB
---main = putStrLn $ show $ ( mkDataTree $ shapeOf exprAB :: Tree () )
---main = putStrLn $ show $ ( shapeOf exprAB :: Tree () )
---main = putStrLn $ show $ shapeOf ( exprAB :: TA )
---main = putStrLn $ show $ wtdShapeOf ( exprAB :: TA )
---main = putStrLn $ show $ wtdShapeOf ( [[1,2],[3],[4,5,6]] :: [[Int]] )
---main = putStrLn $ show $ wtdShapeOf [[1,2],[3],[4,5,6]]
-
- wtdShapeOf :: forall d. Data d => d -> Homo Int
- wtdShapeOf = ghom (const 1) (+) -- as of typing this line, battery died!
-
diff --git a/tests/test-02.hs b/tests/test-02.hs
deleted file mode 100644
--- a/tests/test-02.hs
+++ /dev/null
@@ -1,72 +0,0 @@
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-
--- has to have separate line for Data and Typeable, so not worth it here;
--- can be useful for supplying instances for datatypes in other modules.
-{- LANGUAGE StandaloneDeriving #-}
-
- module Main ( main ) where
-
- import SAI.Data.Generics.Shape.SYB ( Homo, ghom, shapeOf, weightedShapeOf )
- import Data.Data ( Data, Typeable )
---import Data.Generics.Aliases ( mkT )
---import Data.Generics.Schemes ( everywhere )
- import Data.Generics.Aliases ( mkQ )
- import Data.Generics.Aliases ( extQ )
-
-#if 0
- data TC = C1 Float (Int,Int) | C2 TD TC TD deriving ( Data, Typeable )
---data TC = C1 Float (Int,Int) | C2 TD TC TD
- data TD = D TC
- deriving instance Data TD
- deriving instance Typeable TD
---deriving instance ( Data, Typeable ) TD
-#else
- data TC = C1 Float (Int,Int) | C2 TD TC TD deriving ( Data, Typeable )
- data TD = D TC deriving ( Data, Typeable )
-#endif
- exprCD = C2 (D (C1 1.0 (1,2))) (C1 3.0 (3,4)) (D (C1 5.0 (5,6)))
-
---data Result = Result (Int,Int) deriving ( Show, Data, Typeable )
- data Result = Result (Int,Int) deriving ( Show )
- dud_result = Result (0,0)
- pair_result pair = Result pair
-
- main = putStrLn $ show $ test2 exprCD
---main = putStrLn $ show $ test1 exprCD
-
- -- XXX What is needed is mkQ (and perhaps extQ).
- -- This makes a generic query out of a type-specific one.
- -- (Recall that a "query" is a function from d -> r,
- -- where d is generic (forall d. Data d =>).)
-
- test1 :: TC -> Homo Result
- test1 = ghom (mkQ dud_result f) (\r _->r)
---test1 = ghom (mkQ (const dud_result) f) (\r _->r)
- where
- -- This is only generic in the sense that you don't
- -- need to match all ctors?...
--- f :: forall d. Data d => d -> Result
- f (C1 _ pair) = pair_result pair
- f (C2 _ _ d2@(D c)) = f c
- f x = dud_result
-
---test2 :: TC -> Homo Result
- test2 = ghom ((const dud_result) `extQ` fTC `extQ` fTD) (\r _->r)
---test2 = ghom ((const dud_result) `extQ` (mkQ dud_result fTC) `extQ` (mkQ dud_result fTD)) (\r _->r)
---test2 = ghom ((mkQ dud_result fTC) `extQ` (mkQ dud_result fTD)) (\r _->r)
- where
- fTC :: TC -> Result
- fTC (C1 _ pair) = pair_result pair
--- fTC (C2 _ _ d2@(D c)) = fTC c
- fTC x = dud_result
- fTD :: TD -> Result
- fTD (D c) = fTC c
- fTD x = dud_result
-
- wtdShapeOf :: forall d. Data d => d -> Homo Int
- wtdShapeOf = ghom (const 1) (+) -- as of typing this line, battery died!
-
diff --git a/tests/test-03.hs b/tests/test-03.hs
deleted file mode 100644
--- a/tests/test-03.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE StandaloneDeriving #-}
-
- module Main ( main ) where
-
- import SAI.Data.Generics.Shape.SYB ( Homo, ghom, shapeOf, weightedShapeOf )
---import SAI.Data.Generics.Shape.SYB ( Rose(..) )
- import SAI.Data.Generics.Shape.SYB ( showAsParens )
- import Data.Data ( Data, Typeable )
---import Data.Data
- import Data.Generics.Aliases ( extQ )
---import Data.Generics.Aliases ( mkT )
---import Data.Generics.Schemes ( everywhere )
---import Data.Generics ( Generic )
---import Data.Tree ( Tree(..) )
-
- data CompanyType = Company [DepartmentType]
- data DepartmentType = Department String ManagerType [EmployeeType]
- data ManagerType = Manager { rank :: Float
- , manName :: String
- , manSalary :: SalaryType }
- data EmployeeType = Employee { empName :: String
- , empSalary :: SalaryType }
- data SalaryType = Salary Float
- deriving instance Data CompanyType
- deriving instance Data DepartmentType
- deriving instance Data ManagerType
- deriving instance Data EmployeeType
- deriving instance Data SalaryType
- deriving instance Typeable CompanyType
- deriving instance Typeable DepartmentType
- deriving instance Typeable ManagerType
- deriving instance Typeable EmployeeType
- deriving instance Typeable SalaryType
-
- data NiceRecord = NiceRecord { nice_name :: String
- , nice_salary :: Int }
- deriving ( Show )
- dud_record = NiceRecord "" 0
-
-------------------------------
-
- -- small, one department retail company
- company1 = Company [Department "Sales" (Manager 1 "Deborah" (Salary 75000)) [Employee "Jane" (Salary 35000)]]
-
- main = putStrLn $ showAsParens $ shapeOf company1
---main = putStrLn $ show $ shapeOf company1
---main = putStrLn $ show $ test1 company1
---main = putStrLn $ show $ test2 company1
-
- test1 :: CompanyType -> Homo ()
---test1 :: forall d. Data d => d -> Homo ()
- test1 = ghom (\_ _->()) (const ())
-
-#if 0
---test2 :: EmployeeType -> Homo NiceRecord
---test2 :: forall d. Data d => d -> Homo NiceRecord
- test2 = ghom k (const dud_record `extQ` f_EmployeeType `extQ` f_ManagerType)
---test2 = ghom k f
- where
- f_EmployeeType (Employee name (Salary salary))
- = NiceRecord name (floor salary)
- f_ManagerType (Manager _ name _)
- = NiceRecord name 0
- k r _ = r
-#endif
-
diff --git a/tests/test-04.hs b/tests/test-04.hs
deleted file mode 100644
--- a/tests/test-04.hs
+++ /dev/null
@@ -1,248 +0,0 @@
-
-{-# LANGUAGE CPP #-}
-
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE Rank2Types #-}
-{- LANGUAGE ScopedTypeVariables #-}
-
-{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
-
- module Main ( main ) where
-
- import SAI.Data.Generics.Shape.SYB ( Homo, ghom )
- import SAI.Data.Generics.Shape.SYB ( shapeOf, weightedShapeOf )
- import SAI.Data.Generics.Shape.SYB ( showAsParens )
- import SAI.Data.Generics.Shape.SYB ( showAsParensEnriched )
- import SAI.Data.Generics.Shape.SYB ( filterHomo )
---import SAI.Data.Generics.Shape.SYB ( ghomP )
- import SAI.Data.Generics.Shape.SYB ( ghomP' )
- import SAI.Data.Generics.Shape.SYB ( ghomP'' )
- import Data.Data ( Data, Typeable )
- import Data.Generics.Aliases ( mkQ, extQ )
- import Data.Generics.Aliases ( GenericQ )
- import Data.List ( intersperse )
- import Control.Exception ( evaluate )
- import Data.Function ( fix )
-
---import SAI.Data.Generics.Shape.SYB.GHC -- this will add over 10 MB to the executable size (dynamically-linked!)
-
- data TA = A1 | A2 TB TA TB deriving ( Data, Typeable )
- data TB = B TA deriving ( Data, Typeable )
- exprAB = A2 (B A1) A1 (B A1)
-
----------------------------------------
-
- -- often you would not have any Show instance for your
- -- source types, but here it's useful for preparing
- -- my writeup...
- data TC = C1 Float (Int,Int) | C2 TD TC TD | C3 TC
- deriving ( Show, Data, Typeable )
--- deriving ( Data, Typeable )
- data TD = D TC
- deriving ( Show, Data, Typeable )
--- deriving ( Data, Typeable )
- exprCD = C2 (D (C1 1.1 (4,5))) (C3 (C1 2.2 (6,7))) (D (C1 3.3 (8,9)))
-
- data Result = Result (Int,Int) deriving ( Show, Eq, Data, Typeable )
---data Result = Result (Int,Int) deriving ( Show, Eq ) -- Eq for filterHomo
---data Result = Result (Int,Int) deriving ( Show )
- dud_result = Result (0,0)
- pair_result pair = Result pair
-
- test1 :: TC -> Homo Result
- test1 = ghom (\r _->r) (mkQ dud_result f)
- where
- -- This is only generic in the sense that you don't
- -- need to match all ctors; but nodes of other types
- -- will still be traversed (passed over):
--- f :: forall d. Data d => d -> Result
- f (C1 _ pair) = pair_result pair
- f (C2 _ _ d2@(D c)) = let g (Result (x,y)) = Result (y,x) in g (f c)
--- f (C2 _ _ d2@(D c)) = f c -- line above is more interesting
- f x = dud_result -- still needed! (notwithstanding mkQ)
--- f x = x
-
- test1' :: TC -> Homo Result
- test1' = ghomP' p (\r _->r) (mkQ dud_result f)
- where
--- f :: forall d. Data d => d -> Result
- f (C1 _ pair) = pair_result pair
- f (C2 _ _ d2@(D c)) = let g (Result (x,y)) = Result (y,x) in g (f c)
--- f (C2 _ _ d2@(D c)) = f c -- line above is more interesting
- f x = dud_result
--- f x = x
--- p :: Homo Result -> Bool
--- p (R (Result (x,y)) _) = not $ x == 0 && y == 0
- p :: Result -> Bool
- p (Result (x,y)) = not $ x == 0 && y == 0
-
-#if 1
---test1'' :: TC -> Homo Result
---test1'' = ghomP'' (mkQ True p) (\r _->r) (mkQ dud_result f)
- test1'' = ghomP'' p' (\r _->r) (mkQ dud_result f)
- where
-
- f :: TC -> Result -- correct (but unneeded)
---- f :: forall b. Data b => b -> Result -- wrong (we'd like it though)
- f (C1 _ pair) = pair_result pair
- f (C2 _ _ d2@(D c)) = let g (Result (x,y)) = Result (y,x) in g (f c)
--- f (C2 _ _ d2@(D c)) = f c -- line above is more interesting
- f x = dud_result
-
- p :: TC -> Bool -- correct (but unneeded)
---- p :: forall e. (Data e, Typeable e) => e -> Bool -- (would be nice)
- p (C1 _ (i1,i2)) = i1 < 7
--- p (C1 _ (i1,i2)) = i1 < i2
--- p (C2 _ _ d2@(D c)) = p c
- p x = True
- -- one or the other sig. is NEEDED:
--- p' :: forall d. (Data d, Typeable d) => d -> Bool
- p' :: GenericQ Bool
--- p' = mkQ True (\x -> p (x :: (forall d. (Data d, Typeable d) => d)))
--- p' = mkQ True (\x -> p (x :: (forall d. (Data d) => d)))
- p' = mkQ True p
---mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
---type GenericQ r = forall a. Data a => a -> r
---data TC = C1 Float (Int,Int) | C2 TD TC TD deriving ( Data, Typeable )
---data TD = D TC deriving ( Data, Typeable )
-#endif
-
- test2 :: TC -> Homo Result
- test2 = ghom (\r _->r) ((const dud_result) `extQ` fTC `extQ` fTD)
- where
-
- fTC :: TC -> Result
- fTC (C1 _ pair) = pair_result pair
- -- Note we don't need to cover all the cases, or provide a base case;
- -- SYB provides the default case for us automatically.
- fTC x = dud_result
--- fTC x = x
-
- fTD :: TD -> Result
- fTD (D c) = Result (1,1)
--- fTD (D c) = (mkQ (const dud_result) fTC) c -- why not?
--- fTD (D c) = fTC c -- risk non-exhaustive patterns runtime errpr
- fTD x = dud_result
--- fTD x = x
-
----------------------------------------
-
- data CompanyType = Company [DepartmentType]
- data DepartmentType = Department String ManagerType [EmployeeType]
- data ManagerType = Manager { rank :: Float
- , manName :: String
- , manSalary :: SalaryType }
- data EmployeeType = Employee { empName :: String
- , empSalary :: SalaryType }
- data SalaryType = Salary Float
- deriving instance Data CompanyType
- deriving instance Data DepartmentType
- deriving instance Data ManagerType
- deriving instance Data EmployeeType
- deriving instance Data SalaryType
- deriving instance Typeable CompanyType
- deriving instance Typeable DepartmentType
- deriving instance Typeable ManagerType
- deriving instance Typeable EmployeeType
- deriving instance Typeable SalaryType
-
- data NiceRecord = NiceRecord { nice_name :: String
- , nice_salary :: Int }
- deriving ( Show, Eq )
--- deriving ( Show )
- dud_record = NiceRecord "" 0
-
-------------------------------
-
- -- small, one department retail company
- company1 = Company [Department "Sales" (Manager 1 "Deborah" (Salary 75000)) [Employee "Jane" (Salary 35000)]]
-
- test3 :: CompanyType -> Homo ()
---test3 :: forall d. Data d => d -> Homo ()
- test3 = ghom (\_ _->()) (const ())
-
---test4 :: EmployeeType -> Homo NiceRecord
---test4 :: forall d. Data d => d -> Homo NiceRecord
- test4 = ghom k (const dud_record `extQ` f_EmployeeType `extQ` f_ManagerType)
---test4 = ghom k f
- where
- -- No sum types involved, so no explicit defaults
- -- needed (unlike in previous examples).
- f_EmployeeType (Employee name (Salary salary))
- = NiceRecord name (floor salary)
- f_ManagerType (Manager _ name _)
- = NiceRecord name 0
- k r _ = r
-
------------------------------------
-
- main = do
- evaluate (test4 company1)
- putStrLn $ concat $ intersperse "\n" [ ""
-#if 0
-#elif 1
--- , show $ test4' company1
- , "show exprCD\n "
- , show exprCD ++ "\n"
- , "show $ shapeOf exprCD\n "
- , show $ shapeOf exprCD
- , "showAsParens $ shapeOf exprCD\n "
- , (showAsParens $ shapeOf exprCD) ++ "\n"
- , "showAsParens $ weightedShapeOf exprCD\n "
- , (showAsParens $ weightedShapeOf exprCD) ++ "\n"
- , "showAsParensEnriched $ weightedShapeOf exprCD\n "
- , (showAsParensEnriched $ weightedShapeOf exprCD) ++ "\n"
- , "show $ test1 exprCD\n "
- , show $ test1 exprCD
- , "show $ test1' exprCD\n "
- , show $ test1' exprCD
- , "show $ test1'' exprCD\n "
- , show $ test1'' exprCD
- , "show $ filterHomo p1 $ test1'' exprCD\n "
- , show $ filterHomo p1 $ test1'' exprCD
- , "show $ filterHomo p1 $ test1 exprCD\n "
- , show $ filterHomo p1 $ test1 exprCD
- , "show $ test2 exprCD\n "
- , show $ test2 exprCD
- , "show $ filterHomo p1 $ test2 exprCD\n "
- , show $ filterHomo p1 $ test2 exprCD
-#elif 0
- , show $ filterHomo p3 $ test4 company1
-#if 0
- , show $ filterHomo p3 $ shapeOf exprAB
-#endif
- , show $ weightedShapeOf exprAB
- , show $ filterHomo p2 $ weightedShapeOf exprAB
- , show $ weightedShapeOf ( [[1,2],[3],[4,5,6]] :: [[Int]] )
- , show $ filterHomo p2 $ weightedShapeOf ( [[1,2],[3],[4,5,6]] :: [[Int]] )
--- , show $ filterHomo p2 $ weightedShapeOf [[1,2],[3],[4,5,6]]
--- , show $ test2 exprCD
--- , show $ filterHomo p1 $ test2 exprCD
- , show $ test1 exprCD
--- , show $ fix (filterHomo p1) $ test1 exprCD
- , show $ filterHomo p1 $ test1 exprCD
--- , show $ filterHomo p1 $ filterHomo p1 $ test1 exprCD
--- , show $ filterHomo p1 $ filterHomo p1 $ filterHomo p1 $ test1 exprCD
--- , show $ filterHomo p1 $ filterHomo p1 $ filterHomo p1 $ filterHomo p1 $ test1 exprCD
-#elif 0
- , showAsParens $ shapeOf company1
- , show $ shapeOf company1
- , show $ test3 company1
- , show $ test4 company1
- , show $ shapeOf exprAB
- , show $ weightedShapeOf exprAB
- , show $ weightedShapeOf ( [[1,2],[3],[4,5,6]] :: [[Int]] )
--- , show $ weightedShapeOf [[1,2],[3],[4,5,6]]
- , show $ test2 exprCD
- , show $ test1 exprCD
-#endif
- ]
- where
- p1 (Result (x,y)) = not $ x == 0 && y == 0
- p2 x = x /= 3
--- p2 x = x /= ( 3 :: Int )
- p3 = (/= dud_record)
-
------------------------------------
-
diff --git a/tests/test-05.hs b/tests/test-05.hs
deleted file mode 100644
--- a/tests/test-05.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-
- {-# LANGUAGE CPP #-}
-
- module Main ( main ) where
-
- import ShapeSyb ( main_tests )
- import Control.Monad ( void )
-
- main = void main_tests >> return ()
-