syb-0.7.1/0000755000000000000000000000000013501121711010472 5ustar0000000000000000syb-0.7.1/ChangeLog0000644000000000000000000000035313501121711012245 0ustar00000000000000002019-06-15 Sergey Vinokurov * 0.7.1: Define recursive traversals in two parts, non-recursive wrapper and recursive local helper to facilitate inlining and avoid passing the same argument to all recursive calls syb-0.7.1/LICENSE0000644000000000000000000000745013501121711011505 0ustar0000000000000000This library (libraries/syb) is derived from code from several sources: * Code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below), * Code from the Haskell 98 Report which is (c) Simon Peyton Jones and freely redistributable (but see the full license for restrictions). * Code from the Haskell Foreign Function Interface specification, which is (c) Manuel M. T. Chakravarty and freely redistributable (but see the full license for restrictions). The full text of these licenses is reproduced below. All of the licenses are BSD-style or compatible. ----------------------------------------------------------------------------- The Glasgow Haskell Compiler License Copyright 2004, The University Court of the University of Glasgow. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------- Code derived from the document "Report on the Programming Language Haskell 98", is distributed under the following license: Copyright (c) 2002 Simon Peyton Jones The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, including this Notice. Modified versions of this Report may also be copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Language. ----------------------------------------------------------------------------- Code derived from the document "The Haskell 98 Foreign Function Interface, An Addendum to the Haskell 98 Report" is distributed under the following license: Copyright (c) 2002 Manuel M. T. Chakravarty The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, including this Notice. Modified versions of this Report may also be copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Foreign Function Interface. ----------------------------------------------------------------------------- syb-0.7.1/README.md0000644000000000000000000000254013501121711011752 0ustar0000000000000000syb: Scrap Your Boilerplate! ================================================================================ Scrap Your Boilerplate (SYB) is a library for generic programming in Haskell. It is supported since the GHC >= 6.0 implementation of Haskell. Using this approach, you can write generic functions such as traversal schemes (e.g., everywhere and everything), as well as generic read, generic show and generic equality (i.e., gread, gshow, and geq). This approach is based on just a few primitives for type-safe cast and processing constructor applications. It was originally developed by Ralf Lämmel and Simon Peyton Jones. Since then, many people have contributed with research relating to SYB or its applications. More information is available on the webpage: http://www.cs.uu.nl/wiki/GenericProgramming/SYB Features -------- * Easy generic programming with combinators * GHC can derive Data and Typeable instances for your datatypes * Comes with many useful generic functions Requirements ------------ * GHC 6.10.1 or later * Cabal 1.6 or later Bugs & Support -------------- Please report issues or request features at the bug tracker: https://github.com/dreixel/syb/issues For discussion about the library with the authors, maintainers, and other interested persons use the mailing list: http://www.haskell.org/mailman/listinfo/generics syb-0.7.1/syb.cabal0000644000000000000000000000463613501121711012264 0ustar0000000000000000name: syb version: 0.7.1 license: BSD3 license-file: LICENSE author: Ralf Lammel, Simon Peyton Jones, Jose Pedro Magalhaes maintainer: Sergey Vinokurov homepage: http://www.cs.uu.nl/wiki/GenericProgramming/SYB bug-reports: https://github.com/dreixel/syb/issues synopsis: Scrap Your Boilerplate description: This package contains the generics system described in the /Scrap Your Boilerplate/ papers (see ). It defines the @Data@ class of types permitting folding and unfolding of constructor applications, instances of this class for primitive types, and a variety of traversals. category: Generics stability: provisional build-type: Simple cabal-version: >= 1.8 tested-with: GHC >=7.0 && <=7.10.2, GHC==7.11.*, GHC==8.0, GHC==8.2, GHC==8.4.4, GHC==8.6.5 extra-source-files: tests/*.hs, README.md, ChangeLog source-repository head type: git location: https://github.com/dreixel/syb Library hs-source-dirs: src build-depends: base >= 4.0 && < 5.0 exposed-modules: Data.Generics, Data.Generics.Basics, Data.Generics.Instances, Data.Generics.Aliases, Data.Generics.Schemes, Data.Generics.Text, Data.Generics.Twins, Data.Generics.Builders, Generics.SYB, Generics.SYB.Basics, Generics.SYB.Instances, Generics.SYB.Aliases, Generics.SYB.Schemes, Generics.SYB.Text, Generics.SYB.Twins, Generics.SYB.Builders if impl(ghc < 6.12) ghc-options: -package-name syb ghc-options: -Wall test-suite unit-tests type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Main.hs build-depends: base , syb , HUnit , containers , mtl syb-0.7.1/Setup.lhs0000644000000000000000000000011413501121711012276 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain syb-0.7.1/tests/0000755000000000000000000000000013501121711011634 5ustar0000000000000000syb-0.7.1/tests/Encode.hs0000644000000000000000000000436213501121711013372 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} -- A bit more test code for the 2nd boilerplate paper. -- These are downscaled versions of library functionality or real test cases. -- We just wanted to typecheck the fragments as shown in the paper. module Encode () where import Control.Applicative (Applicative(..)) import Control.Monad (ap, liftM) import Data.Generics data Bit = Zero | One ------------------------------------------------------------------------------ -- Sec. 3.2 data2bits :: Data a => a -> [Bit] data2bits t = encodeCon (dataTypeOf t) (toConstr t) ++ concat (gmapQ data2bits t) -- The encoder for constructors encodeCon :: DataType -> Constr -> [Bit] encodeCon ty con = natToBin (max-1) (idx-1) where max = maxConstrIndex ty idx = constrIndex con natToBin :: Int -> Int -> [Bit] natToBin = undefined ------------------------------------------------------------------------------ -- Sec. 3.3 data State -- Abstract initState :: State encodeCon' :: DataType -> Constr -> State -> (State, [Bit]) initState = undefined encodeCon' = undefined data2bits' :: Data a => a -> [Bit] data2bits' t = snd (show_bin t initState) show_bin :: Data a => a -> State -> (State, [Bit]) show_bin t st = (st2, con_bits ++ args_bits) where (st1, con_bits) = encodeCon' (dataTypeOf t) (toConstr t) st (st2, args_bits) = foldr do_arg (st1,[]) enc_args enc_args :: [State -> (State,[Bit])] enc_args = gmapQ show_bin t do_arg fn (st,bits) = (st', bits' ++ bits) where (st', bits') = fn st ------------------------------------------------------------------------------ -- Sec. 3.3 cont'd data EncM a -- The encoder monad instance Functor EncM where fmap = liftM instance Applicative EncM where pure = return (<*>) = ap instance Monad EncM where return = undefined c >>= f = undefined runEnc :: EncM () -> [Bit] emitCon :: DataType -> Constr -> EncM () runEnc = undefined emitCon = undefined data2bits'' :: Data a => a -> [Bit] data2bits'' t = runEnc (emit t) emit :: Data a => a -> EncM () emit t = do { emitCon (dataTypeOf t) (toConstr t) ; sequence_ (gmapQ emit t) } syb-0.7.1/tests/HList.hs0000644000000000000000000000266613501121711013225 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module HList (tests) where {- This module illustrates heterogeneously typed lists. -} import Test.HUnit import Data.Typeable -- Heterogeneously typed lists type HList = [DontKnow] data DontKnow = forall a. Typeable a => DontKnow a -- The empty list initHList :: HList initHList = [] -- Add an entry addHList :: Typeable a => a -> HList -> HList addHList a l = (DontKnow a:l) -- Test for an empty list nullHList :: HList -> Bool nullHList = null -- Retrieve head by type case headHList :: Typeable a => HList -> Maybe a headHList [] = Nothing headHList (DontKnow a:_) = cast a -- Retrieve tail by type case tailHList :: HList -> HList tailHList = tail -- Access per index; starts at 1 nth1HList :: Typeable a => Int -> HList -> Maybe a nth1HList i l = case (l !! (i-1)) of (DontKnow a) -> cast a ---------------------------------------------------------------------------- -- A demo list mylist = addHList (1::Int) $ addHList (True::Bool) $ addHList ("42"::String) $ initHList -- Main function for testing tests = ( show (nth1HList 1 mylist :: Maybe Int) -- shows Just 1 , ( show (nth1HList 1 mylist :: Maybe Bool) -- shows Nothing , ( show (nth1HList 2 mylist :: Maybe Bool) -- shows Just True , ( show (nth1HList 3 mylist :: Maybe String) -- shows Just "42" )))) ~=? output output = ("Just 1",("Nothing",("Just True","Just \"42\"")))syb-0.7.1/tests/Datatype.hs0000644000000000000000000000337713501121711013755 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS -fglasgow-exts #-} -- These are simple tests to observe (data)type representations. module Datatype where import Test.HUnit import Data.Tree import Data.Generics -- A simple polymorphic datatype data MyDataType a = MyDataType a deriving (Typeable, Data) -- Some terms and corresponding type representations myTerm = undefined :: MyDataType Int myTypeRep = typeOf myTerm -- type representation in Typeable myDataType = dataTypeOf myTerm -- datatype representation in Data #if MIN_VERSION_base(4,5,0) myTyCon = typeRepTyCon myTypeRep -- type constructor via Typeable myString1 = tyConName myTyCon -- type constructor via Typeable myString2 = dataTypeName myDataType -- type constructor via Data -- Main function for testing tests = show ( myTypeRep , ( myDataType , ( tyconModule myString1 , ( tyconUQname myString1 , ( tyconModule myString2 , ( tyconUQname myString2 )))))) ~?= output #if __GLASGOW_HASKELL__ >= 709 -- In GHC 7.10 module name is stripped from DataType output = "(MyDataType Int,(DataType {tycon = \"MyDataType\", datarep = AlgRep [MyDataType]},(\"\",(\"MyDataType\",(\"\",\"MyDataType\")))))" #else output = "(MyDataType Int,(DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]},(\"\",(\"MyDataType\",(\"Datatype\",\"MyDataType\")))))" #endif #else tests = show ( myTypeRep, myDataType ) ~?= output #if __GLASGOW_HASKELL__ >= 701 output = "(MyDataType Int,DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]})" #else output = "(Datatype.MyDataType Int,DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]})" #endif #endif syb-0.7.1/tests/Labels.hs0000644000000000000000000000126513501121711013376 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module Labels (tests) where -- This module tests availability of field labels. import Test.HUnit import Data.Generics -- A datatype without labels data NoLabels = NoLabels Int Float deriving (Typeable, Data) -- A datatype with labels data YesLabels = YesLabels { myint :: Int , myfloat :: Float } deriving (Typeable, Data) -- Test terms noLabels = NoLabels 42 3.14 yesLabels = YesLabels 42 3.14 -- Main function for testing tests = ( constrFields $ toConstr noLabels , constrFields $ toConstr yesLabels ) ~=? output output = ([],["myint","myfloat"]) syb-0.7.1/tests/GEq.hs0000644000000000000000000000072713501121711012652 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module GEq (tests) where {- This test exercices GENERIC read, show, and eq for the company datatypes which we use a lot. The output of the program should be "True" which means that "gread" reads what "gshow" shows while the read term is equal to the original term in terms of "geq". -} import Test.HUnit import Data.Generics import CompanyDatatypes tests = ( geq genCom genCom , geq genCom genCom' ) ~=? (True,False) syb-0.7.1/tests/GMapQAssoc.hs0000644000000000000000000000374213501121711014134 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module GMapQAssoc (tests) where {- This example demonstrates the inadequacy of an apparently simpler variation on gmapQ. To this end, let us first recall a few facts. Firstly, function application (including constructor application) is left-associative. This is the reason why we had preferred our generic fold to be left-associative too. (In "The Sketch Of a Polymorphic Symphony" you can find a right-associative generic fold.) Secondly, lists are right-associative. Because of these inverse associativities queries for the synthesis of lists require some extra effort to reflect the left-to-right of immediate subterms in the queried list. In the module Data.Generics, we solve the problem by a common higher-order trick, that is, we do not cons lists during folding but we pass functions on lists starting from the identity function and passing [] to the resulting function. The following example illustrates that we get indeed an undesirable right-to-left order if we just apply the simple constant datatype constructor CONST instead of the higher-order trick. Contributed by Ralf Laemmel, ralf@cwi.nl -} import Test.HUnit import Data.Generics -- The plain constant type constructor newtype CONST x y = CONST x unCONST (CONST x) = x -- A variation on the gmapQ combinator using CONST and not Q gmapQ' :: Data a => (forall a. Data a => a -> u) -> a -> [u] gmapQ' f = unCONST . gfoldl f' z where f' r a = CONST (f a : unCONST r) z = const (CONST []) -- A trivial datatype used for this test case data IntTree = Leaf Int | Fork IntTree IntTree deriving (Typeable, Data) -- Select int if faced with a leaf leaf (Leaf i) = [i] leaf _ = [] -- A test term term = Fork (Leaf 1) (Leaf 2) -- Process test term -- gmapQ gives left-to-right order -- gmapQ' gives right-to-left order -- tests = show ( gmapQ ([] `mkQ` leaf) term , gmapQ' ([] `mkQ` leaf) term ) ~=? output output = show ([[1],[2]],[[2],[1]]) syb-0.7.1/tests/FreeNames.hs0000644000000000000000000000651513501121711014044 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module FreeNames (tests) where {- This example illustrates the kind of traversals that naturally show up in language processing. That is, the free names (say, variables) are derived for a given program fragment. To this end, we need several worker functions that extract declaring and referencing occurrences from given program fragments; see "decsExpr", "decsEqua", etc. below. Then, we need a traversal "freeNames" that traverses over the program fragment in a bottom-up manner so that free names from subterms do not escape to the top when corresponding declarations are provided. The "freeNames" algorithm uses set operations "union" and "//" to compute sets of free names from the declared and referenced names of the root term and free names of the immediate subterms. Contributed by Ralf Laemmel, ralf@cwi.nl -} import Test.HUnit import Data.Generics import Data.List data System = S [Function] deriving (Typeable, Data) data Function = F Name [Equation] deriving (Typeable, Data) data Equation = E [Pattern] Expression System deriving (Typeable, Data) data Pattern = PVar Name | PTerm Name [Pattern] deriving (Typeable, Data) data Expression = Var Name | App Expression Expression | Lambda Name Expression deriving (Typeable, Data) type Name = String -- A little sample program sys1 = S [f1,f2] f1 = F "f1" [e11] f2 = F "f2" [e21,e22] e11 = E [] (Var "id") (S []) e21 = E [ PTerm "C" [ PVar "x" ] ] (Var "x") (S []) e22 = E [] (Var "id") (S []) -- Names declared in an expression decsExpr :: Expression -> [Name] decsExpr (Lambda n _) = [n] decsExpr _ = [] -- Names declared in an equation decsEqua :: Equation -> [Name] decsEqua (E ps _ _) = everything union ([] `mkQ` pvar) ps where pvar (PVar n) = [n] pvar _ = [] -- Names declared in a system decsSyst :: System -> [Name] decsSyst (S l) = nub $ map (\(F n _) -> n) l -- Names referenced in an expression refsExpr :: Expression -> [Name] refsExpr (Var n) = [n] -- Names referenced in an equation refsEqua :: Equation -> [Name] refsEqua (E ps _ _) = everything union ([] `mkQ` pterm) ps where pterm (PTerm n _) = [n] pterm _ = [] -- Combine the above type-specific cases to obtain -- generic functions that find declared and referenced names -- decsFun :: Data a => a -> [Name] decsFun = const [] `extQ` decsExpr `extQ` decsEqua `extQ` decsSyst refsFun :: Data a => a -> [Name] refsFun = const [] `extQ` refsExpr `extQ` refsEqua {- Free name analysis: Take the union of free names obtained from the immediate subterms (via gmapQ) and the names being referred to at the root of the present term, but subtract all the names that are declared at the root. -} freeNames :: Data a => a -> [Name] freeNames x = ( (refsFun x) `union` (nub . concat . gmapQ freeNames) x ) \\ decsFun x {- Print the free names for the sample program sys1; see module FunDatatypes.hs. This should print the list ["id","C"] because the "Prelude" function "id" is used in the sample program, and also the term constructor "C" occurs in a pattern; we assume a language without explicit datatype declarations ;-) -} tests = freeNames sys1 ~=? output output = ["id","C"] syb-0.7.1/tests/GRead2.hs0000644000000000000000000000347513501121711013245 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module GRead2 () where {- For the discussion in the 2nd boilerplate paper, we favour some simplified generic read, which is checked to compile. For the full/real story see Data.Generics.Text. -} import Control.Applicative (Applicative(..)) import Control.Monad (ap, liftM) import Data.Generics gread :: Data a => String -> Maybe a gread input = runDec input readM -- The decoder monad newtype DecM a = D (String -> Maybe (String, a)) instance Functor DecM where fmap = liftM instance Applicative DecM where pure = return (<*>) = ap instance Monad DecM where return a = D (\s -> Just (s,a)) (D m) >>= k = D (\s -> case m s of Nothing -> Nothing Just (s1,a) -> let D n = k a in n s1) runDec :: String -> DecM a -> Maybe a runDec input (D m) = do (_,x) <- m input return x parseConstr :: DataType -> DecM Constr parseConstr ty = D (\s -> match s (dataTypeConstrs ty)) where match :: String -> [Constr] -> Maybe (String, Constr) match _ [] = Nothing match input (con:cons) | take n input == showConstr con = Just (drop n input, con) | otherwise = match input cons where n = length (showConstr con) readM :: forall a. Data a => DecM a readM = read where read :: DecM a read = do { let val = argOf read ; let ty = dataTypeOf val ; constr <- parseConstr ty ; let con::a = fromConstr constr ; gmapM (\_ -> readM) con } argOf :: c a -> a argOf = undefined yareadM :: forall a. Data a => DecM a yareadM = do { let ty = dataTypeOf (undefined::a) ; constr <- parseConstr ty ; let con::a = fromConstr constr ; gmapM (\_ -> yareadM) con } syb-0.7.1/tests/Newtype.hs0000644000000000000000000000054413501121711013626 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS -fglasgow-exts #-} module Newtype (tests) where -- The type of a newtype should treat the newtype as opaque import Test.HUnit import Data.Generics newtype T = MkT Int deriving( Typeable ) tests = show (typeOf (undefined :: T)) ~?= output #if __GLASGOW_HASKELL__ >= 701 output = "T" #else output = "Newtype.T" #endif syb-0.7.1/tests/Tree.hs0000644000000000000000000000645513501121711013101 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module Tree (tests) where {- This example illustrates serialisation and de-serialisation, but we replace *series* by *trees* so to say. -} import Test.HUnit import Control.Monad.Reader import Data.Generics import Data.Maybe import Data.Tree import CompanyDatatypes -- Trealise Data to Tree data2tree :: Data a => a -> Tree String data2tree = gdefault `extQ` atString where atString (x::String) = Node x [] gdefault x = Node (showConstr (toConstr x)) (gmapQ data2tree x) -- De-trealise Tree to Data tree2data :: Data a => Tree String -> Maybe a tree2data = gdefault `extR` atString where atString (Node x []) = Just x gdefault (Node x ts) = res where -- a helper for type capture res = maybe Nothing (kids . fromConstr) con -- the type to constructed ta = fromJust res -- construct constructor con = readConstr (dataTypeOf ta) x -- recursion per kid with accumulation perkid ts = const (tail ts, tree2data (head ts)) -- recurse into kids kids x = do guard (glength x == length ts) snd (gmapAccumM perkid ts x) -- Main function for testing tests = ( genCom , ( data2tree genCom , ( (tree2data (data2tree genCom)) :: Maybe Company , ( Just genCom == tree2data (data2tree genCom) )))) ~=? output output = (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []],(Node {rootLabel = "C", subForest = [Node {rootLabel = "(:)", subForest = [Node {rootLabel = "D", subForest = [Node {rootLabel = "Research", subForest = []},Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Laemmel", subForest = []},Node {rootLabel = "Amsterdam", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "8000.0", subForest = []}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "PU", subForest = [Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Joost", subForest = []},Node {rootLabel = "Amsterdam", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "1000.0", subForest = []}]}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "PU", subForest = [Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Marlow", subForest = []},Node {rootLabel = "Cambridge", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "2000.0", subForest = []}]}]}]},Node {rootLabel = "[]", subForest = []}]}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "D", subForest = [Node {rootLabel = "Strategy", subForest = []},Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Blair", subForest = []},Node {rootLabel = "London", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "100000.0", subForest = []}]}]},Node {rootLabel = "[]", subForest = []}]},Node {rootLabel = "[]", subForest = []}]}]}]},(Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []]),True))) syb-0.7.1/tests/Ext1.hs0000644000000000000000000000523413501121711013015 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} {-# LANGUAGE CPP #-} module Ext1 (tests) where {- This example records some experiments with polymorphic datatypes. -} import Test.HUnit import Data.Generics #if MIN_VERSION_base(4,8,0) import GHC.Base hiding(foldr) #else import GHC.Base #endif -- Unsafe coerce unsafeCoerce :: a -> b unsafeCoerce = unsafeCoerce# -- Handy type constructors newtype ID x = ID { unID :: x } newtype CONST c a = CONST { unCONST :: c } -- Extension of a query with a para. poly. list case extListQ' :: Data d => (d -> q) -> (forall d. [d] -> q) -> d -> q extListQ' def ext d = if isList d then ext (unsafeCoerce d) else def d -- Test extListQ' foo1 :: Data d => d -> Int foo1 = const 0 `extListQ'` length t1 = foo1 True -- should count as 0 t2 = foo1 [True,True] -- should count as 2 -- Infeasible extension of a query with a data-polymorphic list case extListQ'' :: Data d => (d -> q) -> (forall d. Data d => [d] -> q) -> d -> q extListQ'' def ext d = if isList d then undefined -- hard to avoid an ambiguous type else def d -- Test extListQ from Data.Generics.Aliases foo2 :: Data a => a -> Int foo2 = const 0 `ext1Q` list where list :: Data a => [a] -> Int list l = foldr (+) 0 $ map glength l t3 = foo2 (True,True) -- should count as 0 t4 = foo2 [(True,True),(True,True)] -- should count as 2+2=4 -- Customisation for lists without type cast foo3 :: Data a => a -> Int foo3 x = if isList x then foldr (+) 0 $ gmapListQ glength x else 0 t5 = foo3 (True,True) -- should count as 0 t6 = foo3 [(True,True),(True,True)] -- should count as 2+2=4 -- Test for list datatype isList :: Data a => a -> Bool isList x = typeRepTyCon (typeOf x) == typeRepTyCon (typeOf (undefined::[()])) -- Test for nil isNil :: Data a => a -> Bool isNil x = toConstr x == toConstr ([]::[()]) -- Test for cons isCons :: Data a => a -> Bool isCons x = toConstr x == toConstr (():[]) -- gmapQ for polymorphic lists gmapListQ :: forall a q. Data a => (forall a. Data a => a -> q) -> a -> [q] gmapListQ f x = if not $ isList x then error "gmapListQ" else if isNil x then [] else if isCons x then ( gmapQi 0 f x : gmapQi 1 (gmapListQ f) x ) else error "gmapListQ" -- Build nil mkNil :: Data a => a mkNil = fromConstr $ toConstr ([]::[()]) -- Build cons mkCons :: Data a => a mkCons = fromConstr $ toConstr ((undefined:undefined)::[()]) -- Main function for testing tests = ( t1 , ( t2 , ( t3 , ( t4 , ( t5 , ( t6 )))))) ~=? output output = (0,(2,(0,(4,(0,4))))) syb-0.7.1/tests/Bits.hs0000644000000000000000000005262713501121711013105 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module Bits (tests) where {- This test exercices some oldies of generic programming, namely encoding terms as bit streams and decoding these bit streams in turn to obtain terms again. (This sort of function might actually be useful for serialisation and sending companies and other terms over the internet.) Here is how it works. A constuctor is encoded as a bit stream. To this end, we encode the index of the constructor as a binary number of a fixed length taking into account the maximum index for the type at hand. (Similarly, we could view the list of constructors as a binary tree, and then encode a constructor as the path to the constructor in this tree.) If there is just a single constructor, as for newtypes, for example, then the computed bit stream is empty. Otherwise we just recurse into subterms. Well, we need to handle basic datatypes in a special way. We observe such basic datatypes by testing the maximum index to be 0 for the datatype at hand. An efficient encoding should be tuned per basic datatype. The following solution is generic, but it wastes space. That is, we turn the basic value into a string relying on the general Data API. This string can now be encoded by first converting it into a list of bit streams at the term level, which can then be easily encoded as a single bit stream (because lists and bits can be encoded). -} import Test.HUnit import Data.Generics import Data.Char import Data.Maybe import Control.Applicative (Alternative(..), Applicative(..)) import Control.Monad import CompanyDatatypes ----------------------------------------------------------------------------- -- | We need bits and bit streams. data Bit = Zero | One deriving (Show, Eq, Typeable, Data) type Bin = [Bit] ----------------------------------------------------------------------------- -- Compute length of bit stream for a natural lengthNat :: Int -> Int lengthNat x = ceiling (logBase 2 (fromIntegral (x + 1))) -- Encode a natural as a bit stream varNat2bin :: Int -> Bin varNat2bin 0 = [] varNat2bin x = ( ( if even x then Zero else One ) : varNat2bin (x `div` 2) ) -- Encode a natural as a bit stream of fixed length fixedNat2bin :: Int -> Int -> Bin fixedNat2bin 0 0 = [] fixedNat2bin p x | p>0 = ( ( if even x then Zero else One ) : fixedNat2bin (p - 1) (x `div` 2) ) -- Decode a natural bin2nat :: Bin -> Int bin2nat [] = 0 bin2nat (Zero : bs) = 2 * (bin2nat bs) bin2nat (One : bs) = 2 * (bin2nat bs) + 1 ----------------------------------------------------------------------------- -- | Generically map terms to bit streams showBin :: Data t => t -> Bin showBin t = if isAlgType myDataType then con2bin ++ concat (gmapQ showBin t) else showBin base where -- The datatype for introspection myDataType = dataTypeOf t -- Obtain the maximum index for the type at hand max :: Int max = maxConstrIndex myDataType -- Obtain the index for the constructor at hand idx :: Int idx = constrIndex (toConstr t) -- Map basic values to strings, then to lists of bit streams base = map (varNat2bin . ord) (showConstr (toConstr t)) -- Map constructors to bit streams of fixed length con2bin = fixedNat2bin (lengthNat (max - 1)) (idx - 1) ----------------------------------------------------------------------------- -- | A monad on bit streams data ReadB a = ReadB (Bin -> (Maybe a, Bin)) unReadB (ReadB f) = f instance Functor ReadB where fmap = liftM instance Applicative ReadB where pure = return (<*>) = ap instance Alternative ReadB where (<|>) = mplus empty = mzero -- It's a monad. instance Monad ReadB where return a = ReadB (\bs -> (Just a, bs)) (ReadB c) >>= f = ReadB (\bs -> case c bs of (Just a, bs') -> unReadB (f a) bs' (Nothing, bs') -> (Nothing, bs') ) -- It's a bit monad with 0 and +. instance MonadPlus ReadB where mzero = ReadB (\bs -> (Nothing, bs)) (ReadB f) `mplus` (ReadB g) = ReadB (\bs -> case f bs of (Just a, bs') -> (Just a, bs') (Nothing, _) -> g bs ) -- Read a few bits readB :: Int -> ReadB Bin readB x = ReadB (\bs -> if length bs >= x then (Just (take x bs), drop x bs) else (Nothing, bs) ) ----------------------------------------------------------------------------- -- | Generically map bit streams to terms readBin :: Data t => ReadB t readBin = result where -- The worker, which we also use as type argument result = if isAlgType myDataType then do bin <- readB (lengthNat (max - 1)) fromConstrM readBin (bin2con bin) else do str <- readBin con <- str2con (map (chr . bin2nat) str) return (fromConstr con) -- Determine result type myDataType = dataTypeOf (getArg result) where getArg :: ReadB a -> a getArg = undefined -- Obtain the maximum index for the type at hand max :: Int max = maxConstrIndex myDataType -- Convert a bit stream into a constructor bin2con :: Bin -> Constr bin2con bin = indexConstr myDataType ((bin2nat bin) + 1) -- Convert string to constructor; could fail str2con :: String -> ReadB Constr str2con = maybe mzero return . readConstr myDataType ----------------------------------------------------------------------------- tests = ( showBin True , ( showBin [True] , ( showBin (1::Int) , ( showBin "1" , ( showBin genCom , ( geq genCom genCom' )))))) ~=? output where genCom' = fromJust (fst (unReadB readBin (showBin genCom))) :: Company output = ([One],([One,One,Zero],([One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero],([One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero],([One,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,Zero,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,One,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,One,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,Zero,Zero],True))))) syb-0.7.1/tests/GetC.hs0000644000000000000000000000660113501121711013015 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} {-# LANGUAGE OverlappingInstances, UndecidableInstances #-} module GetC (tests) where import Test.HUnit {- Ralf Laemmel, 5 November 2004 Joe Stoy suggested the idiom to test for the outermost constructor. Given is a term t and a constructor f (say the empty constructor application). isC f t returns True if the outermost constructor of t is f. isC f t returns False otherwise. Modulo type checking, i.e., the data type of f and t must be the same. If not, we want to see a type error, of course. -} import Data.Typeable -- to cast t's subterms, which will be reused for f. import Data.Generics -- to access t's subterms and constructors. -- Some silly data types data T1 = T1a Int String | T1b String Int deriving (Typeable, Data) data T2 = T2a Int Int | T2b String String deriving (Typeable, Data) data T3 = T3! Int deriving (Typeable, Data) -- Test cases tests = show [ isC T1a (T1a 1 "foo") -- typechecks, returns True , isC T1a (T1b "foo" 1) -- typechecks, returns False , isC T3 (T3 42)] -- works for strict data too ~=? output -- err = show $ isC T2b (T1b "foo" 1) -- must not typecheck output = show [True,False,True] -- -- We look at a datum a. -- We look at a constructor function f. -- The class GetT checks that f constructs data of type a. -- The class GetC computes maybe the constructor ... -- ... if the subterms of the datum at hand fit for f. -- Finally we compare the constructors. -- isC :: (Data a, GetT f a, GetC f) => f -> a -> Bool isC f t = maybe False ((==) (toConstr t)) con where kids = gmapQ ExTypeable t -- homogenify subterms in list for reuse con = getC f kids -- compute constructor from constructor application -- -- We prepare for a list of kids using existential envelopes. -- We could also just operate on TypeReps for non-strict datatypes. -- data ExTypeable = forall a. Typeable a => ExTypeable a unExTypeable (ExTypeable a) = cast a -- -- Compute the result type of a function type. -- Beware: the TypeUnify constraint causes headache. -- We can't have GetT t t because the FD will be violated then. -- We can't omit the FD because unresolvable overlapping will hold then. -- class GetT f t | f -> t -- FD is optional instance GetT g t => GetT (x -> g) t instance TypeUnify t t' => GetT t t' -- -- Obtain the constructor if term can be completed -- class GetC f where getC :: f -> [ExTypeable] -> Maybe Constr instance (Typeable x, GetC g) => GetC (x -> g) where getC _ [] = Nothing getC (f::x->g) (h:t) = do (x::x) <- unExTypeable h getC (f x) t instance Data t => GetC t where getC y [] = Just $ toConstr y getC _ (_:_) = Nothing -- -- Type unification; we could try this: -- class TypeUnify a b | a -> b, b -> a -- instance TypeUnify a a -- -- However, if the instance is placed in the present module, -- then type improvement would inline this instance. Sigh!!! -- -- So we need type unification with type improvement blocker -- The following solution works with GHC for ages. -- Other solutions; see the HList paper. -- class TypeUnify a b | a -> b, b -> a class TypeUnify' x a b | x a -> b, x b -> a class TypeUnify'' x a b | x a -> b, x b -> a instance TypeUnify' () a b => TypeUnify a b instance TypeUnify'' x a b => TypeUnify' x a b instance TypeUnify'' () a a syb-0.7.1/tests/Twin.hs0000644000000000000000000000441513501121711013115 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module Twin (tests) where {- For the discussion in the 2nd boilerplate paper, we favour some simplified development of twin traversal. So the full general, stepwise story is in Data.Generics.Twin, but the short version from the paper is turned into a test case below. See the paper for an explanation. -} import Test.HUnit import Data.Generics hiding (GQ,gzipWithQ,geq) geq' :: GenericQ (GenericQ Bool) geq' x y = toConstr x == toConstr y && and (gzipWithQ geq' x y) geq :: Data a => a -> a -> Bool geq = geq' newtype GQ r = GQ (GenericQ r) gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r]) gzipWithQ f t1 t2 = gApplyQ (gmapQ (\x -> GQ (f x)) t1) t2 gApplyQ :: Data a => [GQ r] -> a -> [r] gApplyQ qs t = reverse (snd (gfoldlQ k z t)) where k :: ([GQ r], [r]) -> GenericQ ([GQ r], [r]) k (GQ q : qs, rs) child = (qs, q child : rs) z = (qs, []) newtype R r x = R { unR :: r } gfoldlQ :: (r -> GenericQ r) -> r -> GenericQ r gfoldlQ k z t = unR (gfoldl k' z' t) where z' _ = R z k' (R r) c = R (k r c) ----------------------------------------------------------------------------- -- A dependently polymorphic geq geq'' :: Data a => a -> a -> Bool geq'' x y = toConstr x == toConstr y && and (gzipWithQ' geq'' x y) -- A helper type for existentially quantified queries data XQ r = forall a. Data a => XQ (a -> r) -- A dependently polymorphic gzipWithQ gzipWithQ' :: (forall a. Data a => a -> a -> r) -> (forall a. Data a => a -> a -> [r]) gzipWithQ' f t1 t2 = gApplyQ' (gmapQ (\x -> XQ (f x)) t1) t2 -- Apply existentially quantified queries -- Insist on equal types! -- gApplyQ' :: Data a => [XQ r] -> a -> [r] gApplyQ' qs t = reverse (snd (gfoldlQ k z t)) where z = (qs, []) k :: ([XQ r], [r]) -> GenericQ ([XQ r], [r]) k (XQ q : qs, rs) child = (qs, q' child : rs) where q' = error "Twin mismatch" `extQ` q ----------------------------------------------------------------------------- tests = ( geq [True,True] [True,True] , geq [True,True] [True,False] , geq'' [True,True] [True,True] , geq'' [True,True] [True,False] ) ~=? output output = (True,False,True,False) syb-0.7.1/tests/CompanyDatatypes.hs0000644000000000000000000000254213501121711015460 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module CompanyDatatypes where import Data.Generics (Data, Typeable) -- The organisational structure of a company data Company = C [Dept] deriving (Eq, Show, Typeable, Data) data Dept = D Name Manager [Unit] deriving (Eq, Show, Typeable, Data) data Unit = PU Employee | DU Dept deriving (Eq, Show, Typeable, Data) data Employee = E Person Salary deriving (Eq, Show, Typeable, Data) data Person = P Name Address deriving (Eq, Show, Typeable, Data) data Salary = S Float deriving (Eq, Show, Typeable, Data) type Manager = Employee type Name = String type Address = String -- An illustrative company genCom :: Company genCom = C [D "Research" laemmel [PU joost, PU marlow], D "Strategy" blair []] -- A typo for the sake of testing equality; -- (cf. lammel vs. laemmel) genCom' :: Company genCom' = C [D "Research" lammel [PU joost, PU marlow], D "Strategy" blair []] lammel, laemmel, joost, marlow, blair :: Employee lammel = E (P "Lammel" "Amsterdam") (S 8000) laemmel = E (P "Laemmel" "Amsterdam") (S 8000) joost = E (P "Joost" "Amsterdam") (S 1000) marlow = E (P "Marlow" "Cambridge") (S 2000) blair = E (P "Blair" "London") (S 100000) -- Some more test data person1 = P "Lazy" "Home" dept1 = D "Useless" (E person1 undefined) [] syb-0.7.1/tests/Reify.hs0000644000000000000000000002455313501121711013257 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module Reify (tests) where {- The following examples illustrate the reification facilities for type structure. Most notably, we generate shallow terms using the depth of types and constructors as means to steer the generation. -} import Test.HUnit import Data.Maybe import Data.Generics import Control.Monad.State import CompanyDatatypes ------------------------------------------------------------------------------ -- -- Encoding types as values; some other way. -- ------------------------------------------------------------------------------ {- This group provides a style of encoding types as values and using them. This style is seen as an alternative to the pragmatic style used in Data.Typeable.typeOf and elsewhere, i.e., simply use an "undefined" to denote a type argument. This pragmatic style suffers from lack of robustness: one feels tempted to pattern match on undefineds. Maybe Data.Typeable.typeOf etc. should be rewritten accordingly. -} -- | Type as values to stipulate use of undefineds type TypeVal a = a -> () -- | The value that denotes a type typeVal :: TypeVal a typeVal = const () -- | Test for type equivalence sameType :: (Typeable a, Typeable b) => TypeVal a -> TypeVal b -> Bool sameType tva tvb = typeOf (type2val tva) == typeOf (type2val tvb) -- | Map a value to its type val2type :: a -> TypeVal a val2type _ = typeVal -- | Stipulate this idiom! type2val :: TypeVal a -> a type2val _ = undefined -- | Constrain a type withType :: a -> TypeVal a -> a withType x _ = x -- | The argument type of a function argType :: (a -> b) -> TypeVal a argType _ = typeVal -- | The result type of a function resType :: (a -> b) -> TypeVal b resType _ = typeVal -- | The parameter type of type constructor paraType :: t a -> TypeVal a paraType _ = typeVal -- Type functions, -- i.e., functions mapping types to values -- type TypeFun a r = TypeVal a -> r -- Generic type functions, -- i.e., functions mapping types to values -- type GTypeFun r = forall a. Data a => TypeFun a r -- | Extend a type function extType :: (Data a, Typeable r) => GTypeFun r -> TypeFun a r -> GTypeFun r extType f x = maybe f id (cast x) ------------------------------------------------------------------------------ -- -- Mapping operators to map over type structure -- ------------------------------------------------------------------------------ -- | Query all constructors of a given type gmapType :: ([(Constr,r')] -> r) -> GTypeFun (Constr -> r') -> GTypeFun r gmapType (o::[(Constr,r')] -> r) f (t::TypeVal a) = o $ zip cons query where -- All constructors of the given type cons :: [Constr] cons = if isAlgType $ dataTypeOf $ type2val t then dataTypeConstrs $ dataTypeOf $ type2val t else [] -- Query constructors query :: [r'] query = map (f t) cons -- | Query all subterm types of a given constructor gmapConstr :: ([r] -> r') -> GTypeFun r -> GTypeFun (Constr -> r') gmapConstr (o::[r] -> r') f (t::TypeVal a) c = o $ query where -- Term for the given constructor term :: a term = fromConstr c -- Query subterm types query :: [r] query = gmapQ (f . val2type) term -- | Compute arity of a given constructor constrArity :: GTypeFun (Constr -> Int) constrArity t c = glength $ withType (fromConstr c) t -- | Query all immediate subterm types of a given type gmapSubtermTypes :: (Data a, Typeable r) => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r gmapSubtermTypes o (r::r) f (t::TypeVal a) = reduce (concat (map (gmapQ (query . val2type)) terms)) (GTypeFun' f) where -- All constructors of the given type cons :: [Constr] cons = if isAlgType $ dataTypeOf $ type2val t then dataTypeConstrs $ dataTypeOf $ type2val t else [] -- Terms for all constructors terms :: [a] terms = map fromConstr cons -- Query a subterm type query :: Data b => TypeVal b -> GTypeFun' r -> (r,GTypeFun' r) query t f = (unGTypeFun' f t, GTypeFun' (disable t (unGTypeFun' f))) -- Constant out given type disable :: Data b => TypeVal b -> GTypeFun r -> GTypeFun r disable (t::TypeVal b) f = f `extType` \(_::TypeVal b) -> r -- Reduce all subterm types reduce :: [GTypeFun' r -> (r,GTypeFun' r)] -> GTypeFun' r -> r reduce [] _ = r reduce (xy:z) g = fst (xy g) `o` reduce z (snd (xy g)) -- First-class polymorphic variation on GTypeFun newtype GTypeFun' r = GTypeFun' (GTypeFun r) unGTypeFun' (GTypeFun' f) = f -- | Query all immediate subterm types. -- There is an extra argument to \"constant out\" the type at hand. -- This can be used to avoid cycles. gmapSubtermTypesConst :: (Data a, Typeable r) => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r gmapSubtermTypesConst o (r::r) f (t::TypeVal a) = gmapSubtermTypes o r f' t where f' :: GTypeFun r f' = f `extType` \(_::TypeVal a) -> r -- Count all distinct subterm types gcountSubtermTypes :: Data a => TypeVal a -> Int gcountSubtermTypes = gmapSubtermTypes (+) (0::Int) (const 1) -- | A simplied variation on gmapSubtermTypes. -- Weakness: no awareness of doubles. -- Strength: easy to comprehend as it uses gmapType and gmapConstr. _gmapSubtermTypes :: (Data a, Typeable r) => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r _gmapSubtermTypes o (r::r) f = gmapType otype (gmapConstr oconstr f) where otype :: [(Constr,r)] -> r otype = foldr (\x y -> snd x `o` y) r oconstr :: [r] -> r oconstr = foldr o r ------------------------------------------------------------------------------ -- -- Some reifying relations on types -- ------------------------------------------------------------------------------ -- | Reachability relation on types, i.e., -- test if nodes of type @a@ are reachable from nodes of type @b@. -- The relation is defined to be reflexive. reachableType :: (Data a, Data b) => TypeVal a -> TypeVal b -> Bool reachableType (a::TypeVal a) (b::TypeVal b) = or [ sameType a b , gmapSubtermTypesConst (\x y -> or [x,y]) False (reachableType a) b ] -- | Depth of a datatype as the constructor with the minimum depth. -- The outermost 'Nothing' denotes a type without constructors. -- The innermost 'Nothing' denotes potentially infinite. depthOfType :: GTypeFun Bool -> GTypeFun (Maybe (Constr, Maybe Int)) depthOfType p (t::TypeVal a) = gmapType o f t where o :: [(Constr, Maybe Int)] -> Maybe (Constr, Maybe Int) o l = if null l then Nothing else Just (foldr1 min' l) f :: GTypeFun (Constr -> Maybe Int) f = depthOfConstr p' -- Specific minimum operator min' :: (Constr, Maybe Int) -> (Constr, Maybe Int) -> (Constr, Maybe Int) min' x (_, Nothing) = x min' (_, Nothing) x = x min' (c, Just i) (c', Just i') | i <= i' = (c, Just i) min' (c, Just i) (c', Just i') = (c', Just i') -- Updated predicate for unblocked types p' :: GTypeFun Bool p' = p `extType` \(_::TypeVal a) -> False -- | Depth of a constructor. -- Depth is viewed as the maximum depth of all subterm types + 1. -- 'Nothing' denotes potentially infinite. depthOfConstr :: GTypeFun Bool -> GTypeFun (Constr -> Maybe Int) depthOfConstr p (t::TypeVal a) c = gmapConstr o f t c where o :: [Maybe Int] -> Maybe Int o = inc' . foldr max' (Just 0) f :: GTypeFun (Maybe Int) f t' = if p t' then case depthOfType p t' of Nothing -> Just 0 Just (_, x) -> x else Nothing -- Specific maximum operator max' Nothing _ = Nothing max' _ Nothing = Nothing max' (Just i) (Just i') | i >= i' = Just i max' (Just i) (Just i') = Just i' -- Specific increment operator inc' Nothing = Nothing inc' (Just i) = Just (i+1) ------------------------------------------------------------------------------ -- -- Build a shallow term -- ------------------------------------------------------------------------------ shallowTerm :: (forall a. Data a => Maybe a) -> (forall b. Data b => b) shallowTerm cust = result where result :: forall b. Data b => b -- Need a type signature here to bring 'b' into scope result = maybe gdefault id cust where -- The worker, also used for type disambiguation gdefault :: b gdefault = case con of Just (con, Just _) -> fromConstrB (shallowTerm cust) con _ -> error "no shallow term!" -- The type to be constructed typeVal :: TypeVal b typeVal = val2type gdefault -- The most shallow constructor if any con :: Maybe (Constr, Maybe Int) con = depthOfType (const True) typeVal -- For testing shallowTerm shallowTermBase :: GenericR Maybe shallowTermBase = Nothing `extR` Just (1.23::Float) `extR` Just ("foo"::String) -- Sample datatypes data T1 = T1a deriving (Typeable, Data) -- just a constant data T2 = T2 T1 deriving (Typeable, Data) -- little detour data T3 = T3a T3 | T3b T2 deriving (Typeable, Data) -- recursive case data T4 = T4 T3 T3 deriving (Typeable, Data) -- sum matters -- Sample type arguments t0 = typeVal :: TypeVal Int t1 = typeVal :: TypeVal T1 t2 = typeVal :: TypeVal T2 t3 = typeVal :: TypeVal T3 t4 = typeVal :: TypeVal T4 tCompany = typeVal :: TypeVal Company tPerson = typeVal :: TypeVal Person tEmployee = typeVal :: TypeVal Employee tDept = typeVal :: TypeVal Dept -- Test cases test0 = t1 `reachableType` t1 -- True test1 = t1 `reachableType` t2 -- True test2 = t2 `reachableType` t1 -- False test3 = t1 `reachableType` t3 test4 = tPerson `reachableType` tCompany test5 = gcountSubtermTypes tPerson test6 = gcountSubtermTypes tEmployee test7 = gcountSubtermTypes tDept test8 = shallowTerm shallowTermBase :: Person test9 = shallowTerm shallowTermBase :: Employee test10 = shallowTerm shallowTermBase :: Dept tests = ( test0 , ( test1 , ( test2 , ( test3 , ( test4 , ( test5 , ( test6 , ( test7 , ( test8 , ( test9 , ( test10 ))))))))))) ~=? output output = (True,(True,(False,(True,(True,(1,(2,(3,(P "foo" "foo", (E (P "foo" "foo") (S 1.23), D "foo" (E (P "foo" "foo") (S 1.23)) [])))))))))) syb-0.7.1/tests/Typecase2.hs0000644000000000000000000000254013501121711014030 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module Typecase2 (tests) where {- This test provides a variation on typecase1.hs. This time, we use generic show as defined for all instances of Data. Thereby, we get rid of the Show constraint in our functions. So we only keep a single constraint: the one for class Data. -} import Test.HUnit import Data.Generics import Data.Maybe -- Some datatype. data MyData = MyCons String deriving (Typeable, Data) -- -- Some function that performs type case. -- f :: Data a => a -> String f a = (maybe (maybe (maybe others mytys (cast a) ) float (cast a) ) int (cast a) ) where -- do something with ints int :: Int -> String int a = "got an int, incremented: " ++ show (a + 1) -- do something with floats float :: Float -> String float a = "got a float, multiplied by .42: " ++ show (a * 0.42) -- do something with my data mytys :: MyData -> String mytys a = "got my data: " ++ gshow a -- do something with all other data others = "got something else: " ++ gshow a -- -- Test the type case -- tests = ( f (41::Int) , f (88::Float) , f (MyCons "42") , f True) ~=? output output = ( "got an int, incremented: 42" , "got a float, multiplied by .42: 36.96" , "got my data: (MyCons \"42\")" , "got something else: (True)") syb-0.7.1/tests/Ext.hs0000644000000000000000000000162713501121711012736 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module Ext () where -- There were typos in these definitions in the ICFP 2004 paper. import Data.Generics extQ fn spec_fn arg = case gcast (Q spec_fn) of Just (Q spec_fn') -> spec_fn' arg Nothing -> fn arg newtype Q r a = Q (a -> r) extT fn spec_fn arg = case gcast (T spec_fn) of Just (T spec_fn') -> spec_fn' arg Nothing -> fn arg newtype T a = T (a -> a) extM :: (Typeable a, Typeable b) => (a -> m a) -> (b -> m b) -> (a -> m a) extM fn spec_fn = case gcast (M spec_fn) of Just (M spec_fn') -> spec_fn' Nothing -> fn newtype M m a = M (a -> m a) syb-0.7.1/tests/Polymatch.hs0000644000000000000000000000343313501121711014133 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module Polymatch () where import Data.Typeable import Data.Generics -- Representation of kids kids x = gmapQ Kid x -- get all kids type Kids = [Kid] data Kid = forall k. Typeable k => Kid k -- Build term from a list of kids and the constructor fromConstrL :: Data a => Kids -> Constr -> Maybe a fromConstrL l = unIDL . gunfold k z where z c = IDL (Just c) l k (IDL Nothing _) = IDL Nothing undefined k (IDL (Just f) (Kid x:l)) = IDL f' l where f' = case cast x of (Just x') -> Just (f x') _ -> Nothing -- Helper datatype data IDL x = IDL (Maybe x) Kids unIDL (IDL mx _) = mx -- Two sample datatypes data A = A String deriving (Read, Show, Eq, Data, Typeable) data B = B String deriving (Read, Show, Eq, Data, Typeable) -- Mediate between two "left-equal" Either types f :: (Data a, Data b, Show a, Read b) => (a->b) -> Either String a -> Either String b f g (Right a) = Right $ g a -- conversion really needed -- f g (Left s) = Left s -- unappreciated conversion -- f g s = s -- doesn't typecheck -- f g s = deep_rebuild s -- too expensive f g s = just (shallow_rebuild s) -- perhaps this is Ok? -- Get rid of maybies just = maybe (error "tried, but failed.") id -- Just mentioned for completeness' sake deep_rebuild :: (Show a, Read b) => a -> b deep_rebuild = read . show -- For the record: it's possible. shallow_rebuild :: (Data a, Data b) => a -> Maybe b shallow_rebuild a = b where b = fromConstrL (kids a) constr constr = indexConstr (dataTypeOf b) (constrIndex (toConstr a)) -- Test cases a2b (A s) = B s -- silly conversion t1 = f a2b (Left "x") -- prints Left "x" t2 = f a2b (Right (A "y")) -- prints Right (B "y") syb-0.7.1/tests/Main.hs0000644000000000000000000000403713501121711013060 0ustar0000000000000000 module Main where import Test.HUnit import System.Exit import qualified Bits import qualified Builders import qualified Datatype import qualified Ext1 import qualified Ext2 import qualified FoldTree import qualified FreeNames import qualified GEq import qualified GMapQAssoc import qualified GRead import qualified GShow import qualified GShow2 import qualified GZip import qualified GenUpTo import qualified GetC import qualified HList import qualified HOPat import qualified Labels import qualified Newtype import qualified Paradise import qualified Perm import qualified Reify import qualified Strings import qualified Tree import qualified Twin import qualified Typecase1 import qualified Typecase2 import qualified Where import qualified XML import qualified Encode -- no tests, should compile import qualified Ext -- no tests, should compile import qualified GRead2 -- no tests, should compile import qualified LocalQuantors -- no tests, should compile import qualified NestedDatatypes -- no tests, should compile import qualified Polymatch -- no tests, should compile tests = "All" ~: [ Datatype.tests , FoldTree.tests , GetC.tests , GMapQAssoc.tests , GRead.tests , GShow.tests , GShow2.tests , HList.tests , HOPat.tests , Labels.tests , Newtype.tests , Perm.tests , Twin.tests , Typecase1.tests , Typecase2.tests , Where.tests , XML.tests , Tree.tests , Strings.tests , Reify.tests , Paradise.tests , GZip.tests , GEq.tests , GenUpTo.tests , FreeNames.tests , Ext1.tests , Ext2.tests , Bits.tests , Builders.tests ] main = do putStrLn "Running tests for syb..." counts <- runTestTT tests if (failures counts > 0) then exitFailure else exitSuccess syb-0.7.1/tests/GShow2.hs0000644000000000000000000000222413501121711013301 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module GShow2 (tests) where {- This test exercices GENERIC show for the infamous company datatypes. The output of the program should be some representation of the infamous "genCom" company. -} import Test.HUnit import Data.Generics import CompanyDatatypes tests = gshow genCom ~=? output {- Here is another exercise: The following function gshow' is a completely generic variation on gshow. It would print strings as follows: *Main> gshow' "abc" "((:) ('a') ((:) ('b') ((:) ('c') ([]))))" The original gshow does a better job because it is customised for strings: *Main> gshow "foo" "\"foo\"" In fact, this is what Haskell's normal show would also do: *Main> show "foo" "\"foo\"" -} gshow' :: Data a => a -> String gshow' t = "(" ++ showConstr (toConstr t) ++ concat (gmapQ ((++) " " . gshow') t) ++ ")" output = "(C ((:) (D \"Research\" (E (P \"Laemmel\" \"Amsterdam\") (S (8000.0))) ((:) (PU (E (P \"Joost\" \"Amsterdam\") (S (1000.0)))) ((:) (PU (E (P \"Marlow\" \"Cambridge\") (S (2000.0)))) ([])))) ((:) (D \"Strategy\" (E (P \"Blair\" \"London\") (S (100000.0))) ([])) ([]))))" syb-0.7.1/tests/NestedDatatypes.hs0000644000000000000000000000244513501121711015276 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DeriveDataTypeable #-} module NestedDatatypes () where {- We provide an illustrative ScrapYourBoilerplate example for a nested datatype. For clarity, we do not derive the Typeable and Data instances by the deriving mechanism but we show the intended definitions. The overall conclusion is that nested datatypes do not pose any challenge for the ScrapYourBoilerplate scheme. Well, this is maybe not quite true because it seems like we need to allow undecidable instances. -} import Data.Dynamic import Data.Generics -- A nested datatype data Nest a = Box a | Wrap (Nest [a]) deriving Typeable -- The Data instance for the nested datatype instance (Data a, Data [a]) => Data (Nest a) where gfoldl k z (Box a) = z Box `k` a gfoldl k z (Wrap w) = z Wrap `k` w gmapT f (Box a) = Box (f a) gmapT f (Wrap w) = Wrap (f w) toConstr (Box _) = boxConstr toConstr (Wrap _) = wrapConstr gunfold k z c = case constrIndex c of 1 -> k (z Box) 2 -> k (z Wrap) dataTypeOf _ = nestDataType boxConstr = mkConstr nestDataType "Box" [] Prefix wrapConstr = mkConstr nestDataType "Wrap" [] Prefix nestDataType = mkDataType "Main.Nest" [boxConstr,wrapConstr] syb-0.7.1/tests/Where.hs0000644000000000000000000001177013501121711013250 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module Where (tests) where {- This example illustrates some differences between certain traversal schemes. To this end, we use a simple system of datatypes, and the running example shall be to replace "T1a 42" by "T1a 88". It is our intention to illustrate a few dimensions of designing traversals. 1. We can decide on whether we prefer "rewrite steps" (i.e., monomorphic functions on data) that succeed either for all input patterns or only if the encounter a term pattern to be replaced. In the first case, the catch-all equation of such a function describes identity (see "stepid" below). In the second case, the catch-call equation describes failure using the Maybe type constructor (see "stepfail" below). As an intermediate assessment, the failure approach is more general because it allows one to observe if a rewrite step was meaningful or not. Often the identity approach is more convenient and sufficient. 2. We can now also decide on whether we want monadic or simple traversals; recall monadic generic functions GenericM from Data.Generics. The monad can serve for success/failure, state, environment and others. One can now subdivide monadic traversal schemes with respect to the question whether they simply support monadic style of whether they even interact with the relevant monad. The scheme "everywereM" from the library belongs to the first category while "somewhere" belongs to the second category as it uses the operation "mplus" of a monad with addition. So while "everywhereM" makes very well sense without a monad --- as demonstrated by "everywhere", the scheme "somewhere" is immediately monadic. 3. We can now also decide on whether we want rewrite steps to succeed for all possible subterms, at least for one subterm, exactly for one subterm, and others. The various traversal schemes make different assumptions in this respect. a) everywhere By its type, succeeds and requires non-failing rewrite steps. However, we do not get any feedback on whether terms were actually rewritten. (Say, we might have performed accidentally the identity function on all nodes.) b) everywhereM Attempts to reach all nodes where all the sub-traversals are performed in monadic bind-sequence. Failure of the traversal for a given subterm implies failure of the entire traversal. Hence, the argument of "everywhereM" should be designed in a way that it tends to succeed except for the purpose of propagating a proper error in the sense of violating a pre-/post-condition. For example, "mkM stepfail" should not be passed to "everywhereM" as it will fail for all but one term pattern; see "recovered" for a way to massage "stepfail" accordingly. c) somewhere Descends into term in a top-down manner, and stops in a given branch when the argument succeeds for the subterm at hand. To this end, it takes an argument that is perfectly intended to fail for certain term patterns. Thanks to the employment of gmapF, the traversal scheme recovers from failure when mapping over the immediate subterms while insisting success for at least one subterm (say, branch). This scheme is appropriate if you want to make sure that a given rewrite step was actually used in a traversal. So failure of the traversal would mean that the argument failed for all subterms. Contributed by Ralf Laemmel, ralf@cwi.nl -} import Test.HUnit import Data.Generics import Control.Monad -- Two mutually recursive datatypes data T1 = T1a Int | T1b T2 deriving (Typeable, Data) data T2 = T2 T1 deriving (Typeable, Data) -- A rewrite step with identity as catch-all case stepid (T1a 42) = T1a 88 stepid x = x -- The same rewrite step but now with failure as catch-all case stepfail (T1a 42) = Just (T1a 88) stepfail _ = Nothing -- We can let recover potentially failing generic functions from failure; -- this is illustrated for a generic made from stepfail via mkM. recovered x = mkM stepfail x `mplus` Just x -- A test term that comprehends a redex term42 = T1b (T2 (T1a 42)) -- A test term that does not comprehend a redex term37 = T1b (T2 (T1a 37)) -- A number of traversals result1 = everywhere (mkT stepid) term42 -- rewrites term accordingly result2 = everywhere (mkT stepid) term37 -- preserves term without notice result3 = everywhereM (mkM stepfail) term42 -- fails in a harsh manner result4 = everywhereM (mkM stepfail) term37 -- fails rather early result5 = everywhereM recovered term37 -- preserves term without notice result6 = somewhere (mkMp stepfail) term42 -- rewrites term accordingly result7 = somewhere (mkMp stepfail) term37 -- fails to notice lack of redex tests = gshow ( result1, ( result2, ( result3, ( result4, ( result5, ( result6, ( result7 ))))))) ~=? output output = "((,) (T1b (T2 (T1a (88)))) ((,) (T1b (T2 (T1a (37)))) ((,) (Nothing) ((,) (Nothing) ((,) (Just (T1b (T2 (T1a (37))))) ((,) (Just (T1b (T2 (T1a (88))))) (Nothing)))))))" syb-0.7.1/tests/Ext2.hs0000644000000000000000000000276613501121711013025 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Ext2 (tests) where -- Tests for ext2 and friends import Test.HUnit import Data.Generics -- A type of lists data List a = Nil | Cons a (List a) deriving (Data, Typeable, Show, Eq) -- Example lists l1, l2 :: List Int l1 = Cons 1 (Cons 2 Nil) l2 = Cons 0 l1 -- A type of pairs data Pair a b = Pair1 a b | Pair2 a b deriving (Data, Typeable, Show, Eq) -- Example pairs p1, p2 :: Pair Int Char p1 = Pair1 2 'p' p2 = Pair2 3 'q' -- Structures containing the above s1 :: [Pair Int Char] s1 = [p1, p2] s2 :: (Pair Int Char, List Int) s2 = (p2, l2) -- Auxiliary functions unifyPair :: Pair a b -> Pair a b -> Bool unifyPair (Pair1 _ _) (Pair1 _ _) = True unifyPair (Pair2 _ _) (Pair2 _ _) = True unifyPair _ _ = False flipPair :: Pair a b -> Pair a b flipPair (Pair1 a b) = Pair2 a b flipPair (Pair2 a b) = Pair1 a b -- Tests t1 = everywhere (id `ext2T` flipPair) (s1,s2) t2 = let f :: (Data a) => a -> Maybe a f = (const Nothing) `ext2M` (Just . flipPair) in (f p1, f l1) t3 = everything (+) ( const 0 `ext1Q` (const 1 :: List a -> Int) `ext2Q` (const 10 :: Pair a b -> Int)) $ s2 t4 = unifyPair (t4' :: Pair Int Char) t4' where t4' :: Data a => a t4' = undefined `ext1B` Nil `ext2B` (Pair1 undefined undefined) -- Main function for testing tests = (t1, t2, t3, t4) ~=? output output = ((map flipPair s1, (flipPair p2, l2)) ,(Just (flipPair p1),Nothing) ,14 ,True) syb-0.7.1/tests/FoldTree.hs0000644000000000000000000000505713501121711013703 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {- A very, very simple example: "extract all Ints from a tree of Ints". The text book approach is to write a generalised fold for that. One can also turn the Tree datatype into functorial style and then write a Functor instance for the functorial datatype including a definition of fmap. (The original Tree datatype can be related to the functorial version by the usual injection and projection.) You can scrap all such boilerplate by using a traversal scheme based on gmap combinators as illustrated below. To get it a little more interesting, we use a datatype Tree with not just a case for leafs and fork trees, but we also add a case for trees with a weight. For completeness' sake, we mention that the fmap/generalised fold approach differs from the gmap approach in some details. Most notably, the gmap approach does not generally facilitate the identification of term components that relate to the type parameter of a parameterised datatype. The consequence of this is illustrated below as well. Sec. 6.3 in "Scrap Your Boilerplate ..." discusses such `type distinctions' as well. -} module FoldTree (tests) where import Test.HUnit -- Enable "ScrapYourBoilerplate" import Data.Generics -- A parameterised datatype for binary trees with data at the leafs data Tree a w = Leaf a | Fork (Tree a w) (Tree a w) | WithWeight (Tree a w) w deriving (Typeable, Data) -- A typical tree mytree :: Tree Int Int mytree = Fork (WithWeight (Leaf 42) 1) (WithWeight (Fork (Leaf 88) (Leaf 37)) 2) -- A less typical tree, used for testing everythingBut mytree' :: Tree Int Int mytree' = Fork (Leaf 42) (WithWeight (Fork (Leaf 88) (Leaf 37)) 2) -- Print everything like an Int in mytree -- In fact, we show two attempts: -- 1. print really just everything like an Int -- 2. print everything wrapped with Leaf -- So (1.) confuses leafs and weights whereas (2.) does not. -- Additionally we test everythingBut, stopping when we see a WithWeight node tests = show ( listify (\(_::Int) -> True) mytree , everything (++) ([] `mkQ` fromLeaf) mytree , everythingBut (++) (([],False) `mkQ` (\x -> (fromLeaf x, stop x))) mytree' ) ~=? output where fromLeaf :: Tree Int Int -> [Int] fromLeaf (Leaf x) = [x] fromLeaf _ = [] stop :: (Data a, Data b) => Tree a b -> Bool stop (WithWeight _ _) = True stop _ = False output = "([42,1,88,37,2],[42,88,37],[42])" syb-0.7.1/tests/Builders.hs0000644000000000000000000000066713501121711013752 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module Builders (tests) where -- Testing Data.Generics.Builders functionality import Test.HUnit import Data.Data import Data.Generics.Builders -- Main function for testing tests = ( constrs :: [Maybe Int] , constrs :: [String] , constrs :: [Either Int Float] , constrs :: [((), Integer)] ) ~=? output output = ([Nothing,Just 0],["","\NUL"],[Left 0,Right 0.0],[((),0)])syb-0.7.1/tests/Perm.hs0000644000000000000000000001042713501121711013077 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module Perm (tests) where {- This module illustrates permutation phrases. Disclaimer: this is a perhaps naive, certainly undebugged example. -} import Test.HUnit import Control.Applicative (Alternative(..), Applicative(..)) import Control.Monad import Data.Generics --------------------------------------------------------------------------- -- We want to read terms of type T3 regardless of the order T1 and T2. --------------------------------------------------------------------------- data T1 = T1 deriving (Show, Eq, Typeable, Data) data T2 = T2 deriving (Show, Eq, Typeable, Data) data T3 = T3 T1 T2 deriving (Show, Eq, Typeable, Data) --------------------------------------------------------------------------- -- A silly monad that we use to read lists of constructor strings. --------------------------------------------------------------------------- -- Type constructor newtype ReadT a = ReadT { unReadT :: [String] -> Maybe ([String],a) } -- Run a computation runReadT x y = case unReadT x y of Just ([],y) -> Just y _ -> Nothing -- Read one string readT :: ReadT String readT = ReadT (\x -> if null x then Nothing else Just (tail x, head x) ) instance Functor ReadT where fmap = liftM instance Applicative ReadT where pure = return (<*>) = ap instance Alternative ReadT where (<|>) = mplus empty = mzero -- ReadT is a monad! instance Monad ReadT where return x = ReadT (\y -> Just (y,x)) c >>= f = ReadT (\x -> case unReadT c x of Nothing -> Nothing Just (x', a) -> unReadT (f a) x' ) -- ReadT also accommodates mzero and mplus! instance MonadPlus ReadT where mzero = ReadT (const Nothing) f `mplus` g = ReadT (\x -> case unReadT f x of Nothing -> unReadT g x y -> y ) --------------------------------------------------------------------------- -- A helper type to appeal to predicative type system. --------------------------------------------------------------------------- newtype GenM = GenM { unGenM :: forall a. Data a => a -> ReadT a } --------------------------------------------------------------------------- -- The function that reads and copes with all permutations. --------------------------------------------------------------------------- buildT :: forall a. Data a => ReadT a buildT = result where result = do str <- readT con <- string2constr str ske <- return $ fromConstr con fs <- return $ gmapQ buildT' ske perm [] fs ske -- Determine type of data to be constructed myType = myTypeOf result where myTypeOf :: forall a. ReadT a -> a myTypeOf = undefined -- Turn string into constructor string2constr str = maybe mzero return (readConstr (dataTypeOf myType) str) -- Specialise buildT per kid type buildT' :: forall a. Data a => a -> GenM buildT' (_::a) = GenM (const mzero `extM` const (buildT::ReadT a)) -- The permutation exploration function perm :: forall a. Data a => [GenM] -> [GenM] -> a -> ReadT a perm [] [] a = return a perm fs [] a = perm [] fs a perm fs (f:fs') a = ( do a' <- gmapMo (unGenM f) a perm fs fs' a' ) `mplus` ( do guard (not (null fs')) perm (f:fs) fs' a ) --------------------------------------------------------------------------- -- The main function for testing --------------------------------------------------------------------------- tests = ( runReadT buildT ["T1"] :: Maybe T1 -- should parse fine , ( runReadT buildT ["T2"] :: Maybe T2 -- should parse fine , ( runReadT buildT ["T3","T1","T2"] :: Maybe T3 -- should parse fine , ( runReadT buildT ["T3","T2","T1"] :: Maybe T3 -- should parse fine , ( runReadT buildT ["T3","T2","T2"] :: Maybe T3 -- should fail ))))) ~=? output output = (Just T1,(Just T2,(Just (T3 T1 T2),(Just (T3 T1 T2),Nothing)))) syb-0.7.1/tests/LocalQuantors.hs0000644000000000000000000000104613501121711014760 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module LocalQuantors () where -- A datatype with a locally quantified component -- Seems to be too polymorphic to descend into structure! -- Largely irrelevant?! import Data.Generics data Test = Test (GenericT) deriving Typeable instance Data Test where gfoldl _ z x = z x -- folding without descent toConstr (Test _) = testConstr gunfold _ _ = error "gunfold" dataTypeOf _ = testDataType testConstr = mkConstr testDataType "Test" [] Prefix testDataType = mkDataType "Main.Test" [testConstr] syb-0.7.1/tests/XML.hs0000644000000000000000000001451013501121711012631 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module XML (tests) where {- This example illustrates XMLish services to trealise (say, "serialise") heterogenous Haskell data as homogeneous tree structures (say, XMLish elements) and vice versa. -} import Test.HUnit import Control.Applicative (Alternative(..), Applicative(..)) import Control.Monad import Data.Maybe import Data.Generics import CompanyDatatypes -- HaXml-like types for XML elements data Element = Elem Name [Attribute] [Content] deriving (Show, Eq, Typeable, Data) data Content = CElem Element | CString Bool CharData -- ^ bool is whether whitespace is significant | CRef Reference | CMisc Misc deriving (Show, Eq, Typeable, Data) type CharData = String -- In this simple example we disable some parts of XML type Attribute = () type Reference = () type Misc = () -- Trealisation data2content :: Data a => a -> [Content] data2content = element `ext1Q` list `extQ` string `extQ` float where -- Handle an element element x = [CElem (Elem (tyconUQname (dataTypeName (dataTypeOf x))) [] -- no attributes (concat (gmapQ data2content x)))] -- A special case for lists list :: Data a => [a] -> [Content] list = concat . map data2content -- A special case for strings string :: String -> [Content] string x = [CString True x] -- A special case for floats float :: Float -> [Content] float x = [CString True (show x)] -- De-trealisation content2data :: forall a. Data a => ReadX a content2data = result where -- Case-discriminating worker result = element `ext1R` list `extR` string `extR` float -- Determine type of data to be constructed myType = myTypeOf result where myTypeOf :: forall a. ReadX a -> a myTypeOf = undefined -- Handle an element element = do c <- readX case c of (CElem (Elem x as cs)) | as == [] -- no attributes && x == (tyconUQname (dataTypeName (dataTypeOf myType))) -> alts cs _ -> mzero -- A special case for lists list :: forall a. Data a => ReadX [a] list = ( do h <- content2data t <- list return (h:t) ) `mplus` return [] -- Fold over all alternatives, say constructors alts cs = foldr (mplus . recurse cs) mzero shapes -- Possible top-level shapes shapes = map fromConstr consOf -- Retrieve all constructors of the requested type consOf = dataTypeConstrs $ dataTypeOf $ myType -- Recurse into subterms recurse cs x = maybe mzero return (runReadX (gmapM (const content2data) x) cs) -- A special case for strings string :: ReadX String string = do c <- readX case c of (CString _ x) -> return x _ -> mzero -- A special case for floats float :: ReadX Float float = do c <- readX case c of (CString _ x) -> return (read x) _ -> mzero ----------------------------------------------------------------------------- -- -- An XML-hungry parser-like monad -- ----------------------------------------------------------------------------- -- Type constructor newtype ReadX a = ReadX { unReadX :: [Content] -> Maybe ([Content], a) } -- Run a computation runReadX x y = case unReadX x y of Just ([],y) -> Just y _ -> Nothing -- Read one content particle readX :: ReadX Content readX = ReadX (\x -> if null x then Nothing else Just (tail x, head x) ) instance Functor ReadX where fmap = liftM instance Applicative ReadX where pure = return (<*>) = ap instance Alternative ReadX where (<|>) = mplus empty = mzero -- ReadX is a monad! instance Monad ReadX where return x = ReadX (\y -> Just (y,x)) c >>= f = ReadX (\x -> case unReadX c x of Nothing -> Nothing Just (x', a) -> unReadX (f a) x' ) -- ReadX also accommodates mzero and mplus! instance MonadPlus ReadX where mzero = ReadX (const Nothing) f `mplus` g = ReadX (\x -> case unReadX f x of Nothing -> unReadX g x y -> y ) ----------------------------------------------------------------------------- -- -- Main function for testing -- ----------------------------------------------------------------------------- tests = ( genCom , ( data2content genCom , ( zigzag person1 :: Maybe Person , ( zigzag genCom :: Maybe Company , ( zigzag genCom == Just genCom ))))) ~=? output where -- Trealise back and forth zigzag :: Data a => a -> Maybe a zigzag = runReadX content2data . data2content output = (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []],([CElem (Elem "Company" [] [CElem (Elem "Dept" [] [CString True "Research",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Laemmel",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "8000.0"])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Joost",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "1000.0"])])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Marlow",CString True "Cambridge"]),CElem (Elem "Salary" [] [CString True "2000.0"])])])]),CElem (Elem "Dept" [] [CString True "Strategy",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Blair",CString True "London"]),CElem (Elem "Salary" [] [CString True "100000.0"])])])])],(Just (P "Lazy" "Home"),(Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []]),True)))) syb-0.7.1/tests/GenUpTo.hs0000644000000000000000000000641113501121711013513 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module GenUpTo (tests) where {- This example illustrate test-set generation, namely all terms of a given depth are generated. -} import Test.HUnit import Data.Generics {- The following datatypes comprise the abstract syntax of a simple imperative language. Some provisions are such that the discussion of test-set generation is simplified. In particular, we do not consider anything but monomorphic *data*types --- no primitive types, no tuples, ... -} data Prog = Prog Dec Stat deriving (Show, Eq, Typeable, Data) data Dec = Nodec | Ondec Id Type | Manydecs Dec Dec deriving (Show, Eq, Typeable, Data) data Id = A | B deriving (Show, Eq, Typeable, Data) data Type = Int | Bool deriving (Show, Eq, Typeable, Data) data Stat = Noop | Assign Id Exp | Seq Stat Stat deriving (Show, Eq, Typeable, Data) data Exp = Zero | Succ Exp deriving (Show, Eq, Typeable, Data) -- Generate all terms of a given depth genUpTo :: Data a => Int -> [a] genUpTo 0 = [] genUpTo d = result where -- Getting hold of the result (type) result = concat (map recurse cons) -- Retrieve constructors of the requested type cons :: [Constr] cons = dataTypeConstrs (dataTypeOf (head result)) -- Find all terms headed by a specific Constr recurse :: Data a => Constr -> [a] recurse con = gmapM (\_ -> genUpTo (d-1)) (fromConstr con) -- We could also deal with primitive types easily. -- Then we had to use cons' instead of cons. -- cons' :: [Constr] cons' = case dataTypeRep ty of AlgRep cons -> cons IntRep -> [mkIntegralConstr ty 0] FloatRep -> [mkIntegralConstr ty 0] CharRep -> [mkCharConstr ty 'x'] where ty = dataTypeOf (head result) -- For silly tests data T0 = T0 T1 T2 T3 deriving (Show, Eq, Typeable, Data) data T1 = T1a | T1b deriving (Show, Eq, Typeable, Data) data T2 = T2a | T2b deriving (Show, Eq, Typeable, Data) data T3 = T3a | T3b deriving (Show, Eq, Typeable, Data) tests = ( genUpTo 0 :: [Id] , ( genUpTo 1 :: [Id] , ( genUpTo 2 :: [Id] , ( genUpTo 2 :: [T0] , ( genUpTo 3 :: [Prog] ))))) ~=? output output = ([],([A,B],([A,B],([T0 T1a T2a T3a,T0 T1a T2a T3b,T0 T1a T2b T3a,T0 T1a T2b T3b,T0 T1b T2a T3a,T0 T1b T2a T3b,T0 T1b T2b T3a,T0 T1b T2b T3b],[Prog Nodec Noop,Prog Nodec (Assign A Zero),Prog Nodec (Assign B Zero),Prog Nodec (Seq Noop Noop),Prog (Ondec A Int) Noop,Prog (Ondec A Int) (Assign A Zero),Prog (Ondec A Int) (Assign B Zero),Prog (Ondec A Int) (Seq Noop Noop),Prog (Ondec A Bool) Noop,Prog (Ondec A Bool) (Assign A Zero),Prog (Ondec A Bool) (Assign B Zero),Prog (Ondec A Bool) (Seq Noop Noop),Prog (Ondec B Int) Noop,Prog (Ondec B Int) (Assign A Zero),Prog (Ondec B Int) (Assign B Zero),Prog (Ondec B Int) (Seq Noop Noop),Prog (Ondec B Bool) Noop,Prog (Ondec B Bool) (Assign A Zero),Prog (Ondec B Bool) (Assign B Zero),Prog (Ondec B Bool) (Seq Noop Noop),Prog (Manydecs Nodec Nodec) Noop,Prog (Manydecs Nodec Nodec) (Assign A Zero),Prog (Manydecs Nodec Nodec) (Assign B Zero),Prog (Manydecs Nodec Nodec) (Seq Noop Noop)])))) syb-0.7.1/tests/Typecase1.hs0000644000000000000000000000252113501121711014026 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module Typecase1 (tests) where {- This test demonstrates type case as it lives in Data.Typeable. We define a function f that converts typeables into strings in some way. Note: we only need Data.Typeable. Say: Dynamics are NOT involved. -} import Test.HUnit import Data.Typeable import Data.Maybe -- Some datatype. data MyTypeable = MyCons String deriving (Show, Typeable) -- -- Some function that performs type case. -- f :: (Show a, Typeable a) => a -> String f a = (maybe (maybe (maybe others mytys (cast a) ) float (cast a) ) int (cast a) ) where -- do something with ints int :: Int -> String int a = "got an int, incremented: " ++ show (a + 1) -- do something with floats float :: Float -> String float a = "got a float, multiplied by .42: " ++ show (a * 0.42) -- do something with my typeables mytys :: MyTypeable -> String mytys a = "got a term: " ++ show a -- do something with all other typeables others = "got something else: " ++ show a -- -- Test the type case -- tests = ( f (41::Int) , f (88::Float) , f (MyCons "42") , f True) ~=? output output = ( "got an int, incremented: 42" , "got a float, multiplied by .42: 36.96" , "got a term: MyCons \"42\"" , "got something else: True")syb-0.7.1/tests/Paradise.hs0000644000000000000000000000145313501121711013723 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module Paradise (tests) where {- This test runs the infamous PARADISE benchmark, which is the HELLO WORLD example of generic programming, i.e., the "increase salary" function is applied to a typical company just as shown in the boilerplate paper. -} import Test.HUnit import Data.Generics import CompanyDatatypes -- Increase salary by percentage increase :: Float -> Company -> Company increase k = everywhere (mkT (incS k)) -- "interesting" code for increase incS :: Float -> Salary -> Salary incS k (S s) = S (s * (1+k)) tests = increase 0.1 genCom ~=? output output = C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8800.0)) [PU (E (P "Joost" "Amsterdam") (S 1100.0)),PU (E (P "Marlow" "Cambridge") (S 2200.0))],D "Strategy" (E (P "Blair" "London") (S 110000.0)) []] syb-0.7.1/tests/HOPat.hs0000644000000000000000000000332113501121711013142 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module HOPat (tests) where {- This module is in reply to an email by C. Barry Jay received on March 15, and handled within hours. CBJ raises the very interesting issue of higher-order patterns. It turns out that some form of it is readily covered in our setting. -} import Test.HUnit import Data.Generics -- Sample datatypes data T1 = T1a Int | T1b Float deriving (Show, Eq, Typeable, Data) data T2 = T2a T1 T2 | T2b deriving (Show, Eq, Typeable, Data) -- Eliminate a constructor if feasible elim' :: (Data y, Data x) => Constr -> y -> Maybe x elim' c y = if toConstr y == c then unwrap y else Nothing -- Unwrap a term; Return its single component unwrap :: (Data y, Data x) => y -> Maybe x unwrap y = case gmapQ (Nothing `mkQ` Just) y of [Just x] -> Just x _ -> Nothing -- Eliminate a constructor if feasible; 2nd try elim :: forall x y. (Data y, Data x) => (x -> y) -> y -> Maybe x elim c y = elim' (toConstr (c (undefined::x))) y -- Visit a data structure visitor :: (Data x, Data y, Data z) => (x -> y) -> (x -> x) -> z -> z visitor c f = everywhere (mkT g) where g y = case elim c y of Just x -> c (f x) Nothing -> y -- Main function for testing tests = ( ( elim' (toConstr t1a) t1a) :: Maybe Int , ( (elim' (toConstr t1a) t1b) :: Maybe Int , ( (elim T1a t1a) :: Maybe Int , ( (elim T1a t1b) :: Maybe Int , ( (visitor T1a ((+) 46) t2) :: T2 ))))) ~=? output where t1a = T1a 42 t1b = T1b 3.14 t2 = T2a t1a (T2a t1a T2b) output = (Just 42,(Nothing,(Just 42,(Nothing,T2a (T1a 88) (T2a (T1a 88) T2b)))))syb-0.7.1/tests/GShow.hs0000644000000000000000000000225213501121711013220 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module GShow (tests) where {- The generic show example from the 2nd boilerplate paper. (There were some typos in the ICFP 2004 paper.) Also check out Data.Generics.Text. -} import Test.HUnit import Data.Generics hiding (gshow) import Prelude hiding (showString) gshow :: Data a => a -> String gshow = gshow_help `extQ` showString gshow_help :: Data a => a -> String gshow_help t = "(" ++ showConstr (toConstr t) ++ concat (intersperse " " (gmapQ gshow t)) ++ ")" showString :: String -> String showString s = "\"" ++ concat (map escape s) ++ "\"" where escape '\n' = "\\n" escape other_char = [other_char] gshowList :: Data b => [b] -> String gshowList xs = "[" ++ concat (intersperse "," (map gshow xs)) ++ "]" gshow' :: Data a => a -> String gshow' = gshow_help `ext1Q` gshowList `extQ` showString intersperse :: a -> [a] -> [a] intersperse _ [] = [] intersperse x [e] = [e] intersperse x (e:es) = (e:(x:intersperse x es)) tests = ( gshow' "foo" , gshow' [True,False] ) ~=? output output = ("\"foo\"","[(True),(False)]") syb-0.7.1/tests/GZip.hs0000644000000000000000000000277413501121711013053 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module GZip (tests) where {- This test illustrates zipping for the company datatypes which we use a lot. We process two companies that happen to agree on the overall shape but differ in the salaries in a few positions. So whenever we encounter salaries we take the maximum of the two. -} import Test.HUnit import Data.Generics import CompanyDatatypes -- The main function which prints the result of zipping tests = gzip (\x y -> mkTT maxS x y) genCom1 genCom2 ~=? output -- NB: the argument has to be eta-expanded to match -- the type of gzip's argument type, which is -- GenericQ (GenericM Maybe) where -- Variations on the show case company "genCom" genCom1 = everywhere (mkT (double "Joost")) genCom genCom2 = everywhere (mkT (double "Marlow")) genCom double x (E p@(P y _) (S s)) | x == y = E p (S (2*s)) double _ e = e -- Sum up two salaries maxS (S x) (S y) = S (max x y) -- Make a two-arguments, generic function transformer mkTT :: (Typeable a, Typeable b, Typeable c) => (a -> a -> a) -> b -> c -> Maybe c mkTT (f::a -> a -> a) x y = case (cast x,cast y) of (Just (x'::a),Just (y'::a)) -> cast (f x' y') _ -> Nothing output = Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 2000.0)) ,PU (E (P "Marlow" "Cambridge") (S 4000.0))] ,D "Strategy" (E (P "Blair" "London") (S 100000.0)) []]) syb-0.7.1/tests/GRead.hs0000644000000000000000000000234413501121711013155 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module GRead (tests) where {- The following examples achieve branch coverage for the various productions in the definition of gread. Also, negative test cases are provided; see str2 and str3. Also, the potential of heading or trailing spaces as well incomplete parsing of the input is exercised; see str5. -} import Test.HUnit import Data.Generics str1 = "(True)" -- reads fine as a Bool str2 = "(Treu)" -- invalid constructor str3 = "True" -- lacks parentheses str4 = "(1)" -- could be an Int str5 = "( 2 ) ..." -- could be an Int with some trailing left-over str6 = "([])" -- test empty list str7 = "((:)" ++ " " ++ str4 ++ " " ++ str6 ++ ")" tests = show ( ( [ gread str1, gread str2, gread str3 ] , [ gread str4, gread str5 ] , [ gread str6, gread str7 ] ) :: ( [[(Bool, String)]] , [[(Int, String)]] , [[([Int], String)]] ) ) ~=? output output = show ([[(True,"")],[],[]],[[(1,"")],[(2,"...")]],[[([],"")],[([1],"")]]) syb-0.7.1/tests/Strings.hs0000644000000000000000000000076013501121711013624 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} module Strings (tests) where {- This test exercices GENERIC read, show, and eq for the company datatypes which we use a lot. The output of the program should be "True" which means that "gread" reads what "gshow" shows while the read term is equal to the original term in terms of "geq". -} import Test.HUnit import Data.Generics import CompanyDatatypes tests = (case gread (gshow genCom) of [(x,_)] -> geq genCom x _ -> False) ~=? True syb-0.7.1/src/0000755000000000000000000000000013501121711011261 5ustar0000000000000000syb-0.7.1/src/Generics/0000755000000000000000000000000013501121711013020 5ustar0000000000000000syb-0.7.1/src/Generics/SYB.hs0000644000000000000000000000110413501121711014005 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Generics.SYB -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- -- Convenience alias for "Data.Generics". -- ----------------------------------------------------------------------------- module Generics.SYB (module Data.Generics) where import Data.Generics syb-0.7.1/src/Generics/SYB/0000755000000000000000000000000013501121711013455 5ustar0000000000000000syb-0.7.1/src/Generics/SYB/Instances.hs0000644000000000000000000000111413501121711015735 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Generics.SYB.Instances -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- -- Convenience alias for "Data.Generics.Instances". -- ----------------------------------------------------------------------------- module Generics.SYB.Instances () where import Data.Generics.Instances () syb-0.7.1/src/Generics/SYB/Aliases.hs0000644000000000000000000000113513501121711015372 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Generics.SYB.Aliases -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- -- Convenience alias for "Data.Generics.Aliases". -- ----------------------------------------------------------------------------- module Generics.SYB.Aliases (module Data.Generics.Aliases) where import Data.Generics.Aliases syb-0.7.1/src/Generics/SYB/Schemes.hs0000644000000000000000000000113513501121711015400 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Generics.SYB.Schemes -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- -- Convenience alias for "Data.Generics.Schemes". -- ----------------------------------------------------------------------------- module Generics.SYB.Schemes (module Data.Generics.Schemes) where import Data.Generics.Schemes syb-0.7.1/src/Generics/SYB/Text.hs0000644000000000000000000000111613501121711014734 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Generics.SYB.Text -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- -- Convenience alias for "Data.Generics.Text". -- ----------------------------------------------------------------------------- module Generics.SYB.Text (module Data.Generics.Text) where import Data.Generics.Text syb-0.7.1/src/Generics/SYB/Builders.hs0000644000000000000000000000114213501121711015560 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Generics.SYB.Builders -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- -- Convenience alias for "Data.Generics.Builders". -- ----------------------------------------------------------------------------- module Generics.SYB.Builders (module Data.Generics.Builders) where import Data.Generics.Builders syb-0.7.1/src/Generics/SYB/Twins.hs0000644000000000000000000000112313501121711015112 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Generics.SYB.Twins -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- -- Convenience alias for "Data.Generics.Twins". -- ----------------------------------------------------------------------------- module Generics.SYB.Twins (module Data.Generics.Twins) where import Data.Generics.Twins syb-0.7.1/src/Generics/SYB/Basics.hs0000644000000000000000000000113013501121711015210 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Generics.SYB.Basics -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- -- Convenience alias for "Data.Generics.Basics". -- ----------------------------------------------------------------------------- module Generics.SYB.Basics (module Data.Generics.Basics) where import Data.Generics.Basics syb-0.7.1/src/Data/0000755000000000000000000000000013501121711012132 5ustar0000000000000000syb-0.7.1/src/Data/Generics.hs0000644000000000000000000000271413501121711014231 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (uses Data.Generics.Basics) -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell -- See . To scrap your -- boilerplate it is sufficient to import the present module, which simply -- re-exports all themes of the Data.Generics library. -- ----------------------------------------------------------------------------- module Data.Generics ( -- * All Data.Generics modules module Data.Data, -- primitives and instances of the Data class module Data.Generics.Aliases, -- aliases for type case, generic types module Data.Generics.Schemes, -- traversal schemes (everywhere etc.) module Data.Generics.Text, -- generic read and show module Data.Generics.Twins, -- twin traversal, e.g., generic eq module Data.Generics.Builders, -- term builders ) where ------------------------------------------------------------------------------ import Data.Data import Data.Generics.Instances () import Data.Generics.Aliases import Data.Generics.Schemes import Data.Generics.Text import Data.Generics.Twins import Data.Generics.Builders syb-0.7.1/src/Data/Generics/0000755000000000000000000000000013501121711013671 5ustar0000000000000000syb-0.7.1/src/Data/Generics/Instances.hs0000644000000000000000000001351513501121711016161 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Instances -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (uses Data.Data) -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell -- See . The present module -- contains thirteen 'Data' instances which are considered dubious (either -- because the types are abstract or just not meant to be traversed). -- Instances in this module might change or disappear in future releases -- of this package. -- -- (This module does not export anything. It really just defines instances.) -- ----------------------------------------------------------------------------- {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Generics.Instances () where ------------------------------------------------------------------------------ import Data.Data #ifdef __GLASGOW_HASKELL__ #if __GLASGOW_HASKELL__ >= 611 import GHC.IO.Handle -- So we can give Data instance for Handle #else import GHC.IOBase -- So we can give Data instance for IO, Handle #endif import GHC.Stable -- So we can give Data instance for StablePtr import GHC.ST -- So we can give Data instance for ST import GHC.Conc -- So we can give Data instance for TVar import Data.IORef -- So we can give Data instance for IORef import Control.Concurrent -- So we can give Data instance for MVar #else # ifdef __HUGS__ import Hugs.Prelude( Ratio(..) ) # endif import System.IO import Foreign.Ptr import Foreign.ForeignPtr import Foreign.StablePtr import Control.Monad.ST #endif -- Version compatibility issues caused by #2760 myMkNoRepType :: String -> DataType #if __GLASGOW_HASKELL__ >= 611 myMkNoRepType = mkNoRepType #else myMkNoRepType = mkNorepType #endif ------------------------------------------------------------------------------ -- -- Instances of the Data class for Prelude-like types. -- We define top-level definitions for representations. -- ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- Instances of abstract datatypes (6) ------------------------------------------------------------------------------ #if __GLASGOW_HASKELL__ < 801 instance Data TypeRep where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "Data.Typeable.TypeRep" #endif ------------------------------------------------------------------------------ instance Data TyCon where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "Data.Typeable.TyCon" ------------------------------------------------------------------------------ #if __GLASGOW_HASKELL__ < 709 deriving instance Typeable DataType #endif instance Data DataType where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "Data.Generics.Basics.DataType" ------------------------------------------------------------------------------ instance Data Handle where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.IOBase.Handle" ------------------------------------------------------------------------------ instance Typeable a => Data (StablePtr a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.Stable.StablePtr" ------------------------------------------------------------------------------ #ifdef __GLASGOW_HASKELL__ instance Data ThreadId where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.Conc.ThreadId" #endif ------------------------------------------------------------------------------ -- Dubious instances (7) ------------------------------------------------------------------------------ #ifdef __GLASGOW_HASKELL__ instance Typeable a => Data (TVar a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.Conc.TVar" #endif ------------------------------------------------------------------------------ instance Typeable a => Data (MVar a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.Conc.MVar" ------------------------------------------------------------------------------ #ifdef __GLASGOW_HASKELL__ instance Typeable a => Data (STM a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.Conc.STM" #endif ------------------------------------------------------------------------------ instance (Typeable s, Typeable a) => Data (ST s a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.ST.ST" ------------------------------------------------------------------------------ instance Typeable a => Data (IORef a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.IOBase.IORef" ------------------------------------------------------------------------------ instance Typeable a => Data (IO a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.IOBase.IO" ------------------------------------------------------------------------------ -- -- A last resort for functions -- instance (Data a, Data b) => Data (a -> b) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "Prelude.(->)" dataCast2 f = gcast2 f syb-0.7.1/src/Data/Generics/Aliases.hs0000644000000000000000000002561113501121711015613 0ustar0000000000000000{-# LANGUAGE RankNTypes, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Aliases -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell -- See . -- The present module provides a number of declarations for typical generic -- function types, corresponding type case, and others. -- ----------------------------------------------------------------------------- module Data.Generics.Aliases ( -- * Combinators to \"make\" generic functions via cast mkT, mkQ, mkM, mkMp, mkR, ext0, extT, extQ, extM, extMp, extB, extR, -- * Type synonyms for generic function types GenericT, GenericQ, GenericM, GenericB, GenericR, Generic, Generic'(..), GenericT'(..), GenericQ'(..), GenericM'(..), -- * Ingredients of generic functions orElse, -- * Function combinators on generic functions recoverMp, recoverQ, choiceMp, choiceQ, -- * Type extension for unary type constructors ext1, ext1T, ext1M, ext1Q, ext1R, ext1B, -- * Type extension for binary type constructors ext2T, ext2M, ext2Q, ext2R, ext2B ) where #ifdef __HADDOCK__ import Prelude #endif import Control.Monad import Data.Data ------------------------------------------------------------------------------ -- -- Combinators to "make" generic functions -- We use type-safe cast in a number of ways to make generic functions. -- ------------------------------------------------------------------------------ -- | Make a generic transformation; -- start from a type-specific case; -- preserve the term otherwise -- mkT :: ( Typeable a , Typeable b ) => (b -> b) -> a -> a mkT = extT id -- | Make a generic query; -- start from a type-specific case; -- return a constant otherwise -- mkQ :: ( Typeable a , Typeable b ) => r -> (b -> r) -> a -> r (r `mkQ` br) a = case cast a of Just b -> br b Nothing -> r -- | Make a generic monadic transformation; -- start from a type-specific case; -- resort to return otherwise -- mkM :: ( Monad m , Typeable a , Typeable b ) => (b -> m b) -> a -> m a mkM = extM return {- For the remaining definitions, we stick to a more concise style, i.e., we fold maybes with "maybe" instead of case ... of ..., and we also use a point-free style whenever possible. -} -- | Make a generic monadic transformation for MonadPlus; -- use \"const mzero\" (i.e., failure) instead of return as default. -- mkMp :: ( MonadPlus m , Typeable a , Typeable b ) => (b -> m b) -> a -> m a mkMp = extM (const mzero) -- | Make a generic builder; -- start from a type-specific ase; -- resort to no build (i.e., mzero) otherwise -- mkR :: ( MonadPlus m , Typeable a , Typeable b ) => m b -> m a mkR f = mzero `extR` f -- | Flexible type extension ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a ext0 def ext = maybe def id (gcast ext) -- | Extend a generic transformation by a type-specific case extT :: ( Typeable a , Typeable b ) => (a -> a) -> (b -> b) -> a -> a extT def ext = unT ((T def) `ext0` (T ext)) -- | Extend a generic query by a type-specific case extQ :: ( Typeable a , Typeable b ) => (a -> q) -> (b -> q) -> a -> q extQ f g a = maybe (f a) g (cast a) -- | Extend a generic monadic transformation by a type-specific case extM :: ( Monad m , Typeable a , Typeable b ) => (a -> m a) -> (b -> m b) -> a -> m a extM def ext = unM ((M def) `ext0` (M ext)) -- | Extend a generic MonadPlus transformation by a type-specific case extMp :: ( MonadPlus m , Typeable a , Typeable b ) => (a -> m a) -> (b -> m b) -> a -> m a extMp = extM -- | Extend a generic builder extB :: ( Typeable a , Typeable b ) => a -> b -> a extB a = maybe a id . cast -- | Extend a generic reader extR :: ( Monad m , Typeable a , Typeable b ) => m a -> m b -> m a extR def ext = unR ((R def) `ext0` (R ext)) ------------------------------------------------------------------------------ -- -- Type synonyms for generic function types -- ------------------------------------------------------------------------------ -- | Generic transformations, -- i.e., take an \"a\" and return an \"a\" -- type GenericT = forall a. Data a => a -> a -- | Generic queries of type \"r\", -- i.e., take any \"a\" and return an \"r\" -- type GenericQ r = forall a. Data a => a -> r -- | Generic monadic transformations, -- i.e., take an \"a\" and compute an \"a\" -- type GenericM m = forall a. Data a => a -> m a -- | Generic builders -- i.e., produce an \"a\". -- type GenericB = forall a. Data a => a -- | Generic readers, say monadic builders, -- i.e., produce an \"a\" with the help of a monad \"m\". -- type GenericR m = forall a. Data a => m a -- | The general scheme underlying generic functions -- assumed by gfoldl; there are isomorphisms such as -- GenericT = Generic T. -- type Generic c = forall a. Data a => a -> c a -- | Wrapped generic functions; -- recall: [Generic c] would be legal but [Generic' c] not. -- data Generic' c = Generic' { unGeneric' :: Generic c } -- | Other first-class polymorphic wrappers newtype GenericT' = GT { unGT :: forall a. Data a => a -> a } newtype GenericQ' r = GQ { unGQ :: GenericQ r } newtype GenericM' m = GM { unGM :: forall a. Data a => a -> m a } -- | Left-biased choice on maybes orElse :: Maybe a -> Maybe a -> Maybe a x `orElse` y = case x of Just _ -> x Nothing -> y {- The following variations take "orElse" to the function level. Furthermore, we generalise from "Maybe" to any "MonadPlus". This makes sense for monadic transformations and queries. We say that the resulting combinators modell choice. We also provide a prime example of choice, that is, recovery from failure. In the case of transformations, we recover via return whereas for queries a given constant is returned. -} -- | Choice for monadic transformations choiceMp :: MonadPlus m => GenericM m -> GenericM m -> GenericM m choiceMp f g x = f x `mplus` g x -- | Choice for monadic queries choiceQ :: MonadPlus m => GenericQ (m r) -> GenericQ (m r) -> GenericQ (m r) choiceQ f g x = f x `mplus` g x -- | Recover from the failure of monadic transformation by identity recoverMp :: MonadPlus m => GenericM m -> GenericM m recoverMp f = f `choiceMp` return -- | Recover from the failure of monadic query by a constant recoverQ :: MonadPlus m => r -> GenericQ (m r) -> GenericQ (m r) recoverQ r f = f `choiceQ` const (return r) ------------------------------------------------------------------------------ -- Type extension for unary type constructors ------------------------------------------------------------------------------ #if __GLASGOW_HASKELL__ >= 707 #define Typeable1 Typeable #define Typeable2 Typeable #endif -- | Flexible type extension ext1 :: (Data a, Typeable1 t) => c a -> (forall d. Data d => c (t d)) -> c a ext1 def ext = maybe def id (dataCast1 ext) -- | Type extension of transformations for unary type constructors ext1T :: (Data d, Typeable1 t) => (forall e. Data e => e -> e) -> (forall f. Data f => t f -> t f) -> d -> d ext1T def ext = unT ((T def) `ext1` (T ext)) -- | Type extension of monadic transformations for type constructors ext1M :: (Monad m, Data d, Typeable1 t) => (forall e. Data e => e -> m e) -> (forall f. Data f => t f -> m (t f)) -> d -> m d ext1M def ext = unM ((M def) `ext1` (M ext)) -- | Type extension of queries for type constructors ext1Q :: (Data d, Typeable1 t) => (d -> q) -> (forall e. Data e => t e -> q) -> d -> q ext1Q def ext = unQ ((Q def) `ext1` (Q ext)) -- | Type extension of readers for type constructors ext1R :: (Monad m, Data d, Typeable1 t) => m d -> (forall e. Data e => m (t e)) -> m d ext1R def ext = unR ((R def) `ext1` (R ext)) -- | Type extension of builders for type constructors ext1B :: (Data a, Typeable1 t) => a -> (forall b. Data b => (t b)) -> a ext1B def ext = unB ((B def) `ext1` (B ext)) ------------------------------------------------------------------------------ -- Type extension for binary type constructors ------------------------------------------------------------------------------ -- | Flexible type extension ext2 :: (Data a, Typeable2 t) => c a -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2)) -> c a ext2 def ext = maybe def id (dataCast2 ext) -- | Type extension of transformations for unary type constructors ext2T :: (Data d, Typeable2 t) => (forall e. Data e => e -> e) -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> t d1 d2) -> d -> d ext2T def ext = unT ((T def) `ext2` (T ext)) -- | Type extension of monadic transformations for type constructors ext2M :: (Monad m, Data d, Typeable2 t) => (forall e. Data e => e -> m e) -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> m (t d1 d2)) -> d -> m d ext2M def ext = unM ((M def) `ext2` (M ext)) -- | Type extension of queries for type constructors ext2Q :: (Data d, Typeable2 t) => (d -> q) -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q ext2Q def ext = unQ ((Q def) `ext2` (Q ext)) -- | Type extension of readers for type constructors ext2R :: (Monad m, Data d, Typeable2 t) => m d -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2)) -> m d ext2R def ext = unR ((R def) `ext2` (R ext)) -- | Type extension of builders for type constructors ext2B :: (Data a, Typeable2 t) => a -> (forall d1 d2. (Data d1, Data d2) => (t d1 d2)) -> a ext2B def ext = unB ((B def) `ext2` (B ext)) ------------------------------------------------------------------------------ -- -- Type constructors for type-level lambdas -- ------------------------------------------------------------------------------ -- | The type constructor for transformations newtype T x = T { unT :: x -> x } -- | The type constructor for transformations newtype M m x = M { unM :: x -> m x } -- | The type constructor for queries newtype Q q x = Q { unQ :: x -> q } -- | The type constructor for readers newtype R m x = R { unR :: m x } -- | The type constructor for builders newtype B x = B {unB :: x} syb-0.7.1/src/Data/Generics/Schemes.hs0000644000000000000000000001350113501121711015614 0ustar0000000000000000{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Schemes -- Copyright : (c) The University of Glasgow, CWI 2001--2003 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell -- See . The present module -- provides frequently used generic traversal schemes. -- ----------------------------------------------------------------------------- module Data.Generics.Schemes ( everywhere, everywhere', everywhereBut, everywhereM, somewhere, everything, everythingBut, everythingWithContext, listify, something, synthesize, gsize, glength, gdepth, gcount, gnodecount, gtypecount, gfindtype ) where ------------------------------------------------------------------------------ #ifdef __HADDOCK__ import Prelude #endif import Data.Data import Data.Generics.Aliases import Control.Monad -- | Apply a transformation everywhere in bottom-up manner everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a) -- Use gmapT to recurse into immediate subterms; -- recall: gmapT preserves the outermost constructor; -- post-process recursively transformed result via f -- everywhere f = go where go :: forall a. Data a => a -> a go = f . gmapT go -- | Apply a transformation everywhere in top-down manner everywhere' :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a) -- Arguments of (.) are flipped compared to everywhere everywhere' f = go where go :: forall a. Data a => a -> a go = gmapT go . f -- | Variation on everywhere with an extra stop condition everywhereBut :: GenericQ Bool -> GenericT -> GenericT -- Guarded to let traversal cease if predicate q holds for x everywhereBut q f = go where go :: GenericT go x | q x = x | otherwise = f (gmapT go x) -- | Monadic variation on everywhere everywhereM :: forall m. Monad m => GenericM m -> GenericM m -- Bottom-up order is also reflected in order of do-actions everywhereM f = go where go :: GenericM m go x = do x' <- gmapM go x f x' -- | Apply a monadic transformation at least somewhere somewhere :: forall m. MonadPlus m => GenericM m -> GenericM m -- We try "f" in top-down manner, but descent into "x" when we fail -- at the root of the term. The transformation fails if "f" fails -- everywhere, say succeeds nowhere. -- somewhere f = go where go :: GenericM m go x = f x `mplus` gmapMp go x -- | Summarise all nodes in top-down, left-to-right order everything :: forall r. (r -> r -> r) -> GenericQ r -> GenericQ r -- Apply f to x to summarise top-level node; -- use gmapQ to recurse into immediate subterms; -- use ordinary foldl to reduce list of intermediate results -- everything k f = go where go :: GenericQ r go x = foldl k (f x) (gmapQ go x) -- | Variation of "everything" with an added stop condition everythingBut :: forall r. (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r everythingBut k f = go where go :: GenericQ r go x = let (v, stop) = f x in if stop then v else foldl k v (gmapQ go x) -- | Summarise all nodes in top-down, left-to-right order, carrying some state -- down the tree during the computation, but not left-to-right to siblings. everythingWithContext :: forall s r. s -> (r -> r -> r) -> GenericQ (s -> (r, s)) -> GenericQ r everythingWithContext s0 f q = go s0 where go :: s -> GenericQ r go s x = foldl f r (gmapQ (go s') x) where (r, s') = q x s -- | Get a list of all entities that meet a predicate listify :: Typeable r => (r -> Bool) -> GenericQ [r] listify p = everything (++) ([] `mkQ` (\x -> if p x then [x] else [])) -- | Look up a subterm by means of a maybe-typed filter something :: GenericQ (Maybe u) -> GenericQ (Maybe u) -- "something" can be defined in terms of "everything" -- when a suitable "choice" operator is used for reduction -- something = everything orElse -- | Bottom-up synthesis of a data structure; -- 1st argument z is the initial element for the synthesis; -- 2nd argument o is for reduction of results from subterms; -- 3rd argument f updates the synthesised data according to the given term -- synthesize :: forall s t. s -> (t -> s -> s) -> GenericQ (s -> t) -> GenericQ t synthesize z o f = go where go :: GenericQ t go x = f x (foldr o z (gmapQ go x)) -- | Compute size of an arbitrary data structure gsize :: Data a => a -> Int gsize t = 1 + sum (gmapQ gsize t) -- | Count the number of immediate subterms of the given term glength :: GenericQ Int glength = length . gmapQ (const ()) -- | Determine depth of the given term gdepth :: GenericQ Int gdepth = (+) 1 . foldr max 0 . gmapQ gdepth -- | Determine the number of all suitable nodes in a given term gcount :: GenericQ Bool -> GenericQ Int gcount p = everything (+) (\x -> if p x then 1 else 0) -- | Determine the number of all nodes in a given term gnodecount :: GenericQ Int gnodecount = gcount (const True) -- | Determine the number of nodes of a given type in a given term gtypecount :: Typeable a => a -> GenericQ Int gtypecount (_::a) = gcount (False `mkQ` (\(_::a) -> True)) -- | Find (unambiguously) an immediate subterm of a given type gfindtype :: (Data x, Typeable y) => x -> Maybe y gfindtype = singleton . foldl unJust [] . gmapQ (Nothing `mkQ` Just) where unJust l (Just x) = x:l unJust l Nothing = l singleton [s] = Just s singleton _ = Nothing syb-0.7.1/src/Data/Generics/Text.hs0000644000000000000000000000772313501121711015162 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Text -- Copyright : (c) The University of Glasgow, CWI 2001--2003 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (uses Data.Generics.Basics) -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell -- See . The present module -- provides generic operations for text serialisation of terms. -- ----------------------------------------------------------------------------- module Data.Generics.Text ( -- * Generic show gshow, gshows, -- * Generic read gread ) where ------------------------------------------------------------------------------ #ifdef __HADDOCK__ import Prelude #endif import Control.Monad import Data.Data import Data.Generics.Aliases import Text.ParserCombinators.ReadP import Text.Read.Lex ------------------------------------------------------------------------------ -- | Generic show: an alternative to \"deriving Show\" gshow :: Data a => a -> String gshow x = gshows x "" -- | Generic shows gshows :: Data a => a -> ShowS -- This is a prefix-show using surrounding "(" and ")", -- where we recurse into subterms with gmapQ. gshows = ( \t -> showChar '(' . (showString . showConstr . toConstr $ t) . (foldr (.) id . gmapQ ((showChar ' ' .) . gshows) $ t) . showChar ')' ) `extQ` (shows :: String -> ShowS) -- | Generic read: an alternative to \"deriving Read\" gread :: Data a => ReadS a {- This is a read operation which insists on prefix notation. (The Haskell 98 read deals with infix operators subject to associativity and precedence as well.) We use fromConstrM to "parse" the input. To be precise, fromConstrM is used for all types except String. The type-specific case for String uses basic String read. -} gread = readP_to_S gread' where -- Helper for recursive read gread' :: Data a' => ReadP a' gread' = allButString `extR` stringCase where -- A specific case for strings stringCase :: ReadP String stringCase = readS_to_P reads -- Determine result type myDataType = dataTypeOf (getArg allButString) where getArg :: ReadP a'' -> a'' getArg = undefined -- The generic default for gread allButString = do -- Drop " ( " skipSpaces -- Discard leading space _ <- char '(' -- Parse '(' skipSpaces -- Discard following space -- Do the real work str <- parseConstr -- Get a lexeme for the constructor con <- str2con str -- Convert it to a Constr (may fail) x <- fromConstrM gread' con -- Read the children -- Drop " ) " skipSpaces -- Discard leading space _ <- char ')' -- Parse ')' skipSpaces -- Discard following space return x -- Turn string into constructor driven by the requested result type, -- failing in the monad if it isn't a constructor of this data type str2con :: String -> ReadP Constr str2con = maybe mzero return . readConstr myDataType -- Get a Constr's string at the front of an input string parseConstr :: ReadP String parseConstr = string "[]" -- Compound lexeme "[]" <++ string "()" -- singleton "()" <++ infixOp -- Infix operator in parantheses <++ hsLex -- Ordinary constructors and literals -- Handle infix operators such as (:) infixOp :: ReadP String infixOp = do c1 <- char '(' str <- munch1 (not . (==) ')') c2 <- char ')' return $ [c1] ++ str ++ [c2] syb-0.7.1/src/Data/Generics/Builders.hs0000644000000000000000000000357013501121711016003 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Builders -- Copyright : (c) 2008 Universiteit Utrecht -- License : BSD-style -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable -- -- This module provides generic builder functions. These functions construct -- values of a given type. ----------------------------------------------------------------------------- module Data.Generics.Builders (empty, constrs) where import Data.Data import Data.Generics.Aliases (extB) -- | Construct the empty value for a datatype. For algebraic datatypes, the -- leftmost constructor is chosen. empty :: forall a. Data a => a empty = general `extB` char `extB` int `extB` integer `extB` float `extB` double where -- Generic case general :: Data a => a general = fromConstrB empty (indexConstr (dataTypeOf general) 1) -- Base cases char = '\NUL' int = 0 :: Int integer = 0 :: Integer float = 0.0 :: Float double = 0.0 :: Double -- | Return a list of values of a datatype. Each value is one of the possible -- constructors of the datatype, populated with 'empty' values. constrs :: forall a. Data a => [a] constrs = general `extB` char `extB` int `extB` integer `extB` float `extB` double where -- Generic case general :: Data a => [a] general = map (fromConstrB empty) (dataTypeConstrs (dataTypeOf (unList general))) where unList :: Data a => [a] -> a unList = undefined -- Base cases char = "\NUL" int = [0 :: Int] integer = [0 :: Integer] float = [0.0 :: Float] double = [0.0 :: Double] syb-0.7.1/src/Data/Generics/Twins.hs0000644000000000000000000002100413501121711015326 0ustar0000000000000000{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Twins -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell -- See . The present module -- provides support for multi-parameter traversal, which is also -- demonstrated with generic operations like equality. -- ----------------------------------------------------------------------------- module Data.Generics.Twins ( -- * Generic folds and maps that also accumulate gfoldlAccum, gmapAccumT, gmapAccumM, gmapAccumQl, gmapAccumQr, gmapAccumQ, gmapAccumA, -- * Mapping combinators for twin traversal gzipWithT, gzipWithM, gzipWithQ, -- * Typical twin traversals geq, gzip, gcompare ) where ------------------------------------------------------------------------------ #ifdef __HADDOCK__ import Prelude #endif import Data.Data import Data.Generics.Aliases #ifdef __GLASGOW_HASKELL__ import Prelude hiding ( GT ) #endif #if __GLASGOW_HASKELL__ < 709 import Control.Applicative (Applicative(..)) import Data.Monoid ( mappend, mconcat ) #endif ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- -- Generic folds and maps that also accumulate -- ------------------------------------------------------------------------------ {-------------------------------------------------------------- A list map can be elaborated to perform accumulation. In the same sense, we can elaborate generic maps over terms. We recall the type of map: map :: (a -> b) -> [a] -> [b] We recall the type of an accumulating map (see Data.List): mapAccumL :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c]) Applying the same scheme we obtain an accumulating gfoldl. --------------------------------------------------------------} -- | gfoldl with accumulation gfoldlAccum :: Data d => (forall e r. Data e => a -> c (e -> r) -> e -> (a, c r)) -> (forall g. a -> g -> (a, c g)) -> a -> d -> (a, c d) gfoldlAccum k z a0 d = unA (gfoldl k' z' d) a0 where k' c y = A (\a -> let (a', c') = unA c a in k a' c' y) z' f = A (\a -> z a f) -- | A type constructor for accumulation newtype A a c d = A { unA :: a -> (a, c d) } -- | gmapT with accumulation gmapAccumT :: Data d => (forall e. Data e => a -> e -> (a,e)) -> a -> d -> (a, d) gmapAccumT f a0 d0 = let (a1, d1) = gfoldlAccum k z a0 d0 in (a1, unID d1) where k a (ID c) d = let (a',d') = f a d in (a', ID (c d')) z a x = (a, ID x) -- | Applicative version gmapAccumA :: forall b d a. (Data d, Applicative a) => (forall e. Data e => b -> e -> (b, a e)) -> b -> d -> (b, a d) gmapAccumA f a0 d0 = gfoldlAccum k z a0 d0 where k :: forall d' e. (Data d') => b -> a (d' -> e) -> d' -> (b, a e) k a c d = let (a',d') = f a d c' = c <*> d' in (a', c') z :: forall t c a'. (Applicative a') => t -> c -> (t, a' c) z a x = (a, pure x) -- | gmapM with accumulation gmapAccumM :: (Data d, Monad m) => (forall e. Data e => a -> e -> (a, m e)) -> a -> d -> (a, m d) gmapAccumM f = gfoldlAccum k z where k a c d = let (a',d') = f a d in (a', d' >>= \d'' -> c >>= \c' -> return (c' d'')) z a x = (a, return x) -- | gmapQl with accumulation gmapAccumQl :: Data d => (r -> r' -> r) -> r -> (forall e. Data e => a -> e -> (a,r')) -> a -> d -> (a, r) gmapAccumQl o r0 f a0 d0 = let (a1, r1) = gfoldlAccum k z a0 d0 in (a1, unCONST r1) where k a (CONST c) d = let (a', r) = f a d in (a', CONST (c `o` r)) z a _ = (a, CONST r0) -- | gmapQr with accumulation gmapAccumQr :: Data d => (r' -> r -> r) -> r -> (forall e. Data e => a -> e -> (a,r')) -> a -> d -> (a, r) gmapAccumQr o r0 f a0 d0 = let (a1, l) = gfoldlAccum k z a0 d0 in (a1, unQr l r0) where k a (Qr c) d = let (a',r') = f a d in (a', Qr (\r -> c (r' `o` r))) z a _ = (a, Qr id) -- | gmapQ with accumulation gmapAccumQ :: Data d => (forall e. Data e => a -> e -> (a,q)) -> a -> d -> (a, [q]) gmapAccumQ f = gmapAccumQr (:) [] f ------------------------------------------------------------------------------ -- -- Helper type constructors -- ------------------------------------------------------------------------------ -- | The identity type constructor needed for the definition of gmapAccumT newtype ID x = ID { unID :: x } -- | The constant type constructor needed for the definition of gmapAccumQl newtype CONST c a = CONST { unCONST :: c } -- | The type constructor needed for the definition of gmapAccumQr newtype Qr r a = Qr { unQr :: r -> r } ------------------------------------------------------------------------------ -- -- Mapping combinators for twin traversal -- ------------------------------------------------------------------------------ -- | Twin map for transformation gzipWithT :: GenericQ (GenericT) -> GenericQ (GenericT) gzipWithT f x y = case gmapAccumT perkid funs y of ([], c) -> c _ -> error "gzipWithT" where perkid a d = (tail a, unGT (head a) d) funs = gmapQ (\k -> GT (f k)) x -- | Twin map for monadic transformation gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m) gzipWithM f x y = case gmapAccumM perkid funs y of ([], c) -> c _ -> error "gzipWithM" where perkid a d = (tail a, unGM (head a) d) funs = gmapQ (\k -> GM (f k)) x -- | Twin map for queries gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r]) gzipWithQ f x y = case gmapAccumQ perkid funs y of ([], r) -> r _ -> error "gzipWithQ" where perkid a d = (tail a, unGQ (head a) d) funs = gmapQ (\k -> GQ (f k)) x ------------------------------------------------------------------------------ -- -- Typical twin traversals -- ------------------------------------------------------------------------------ -- | Generic equality: an alternative to \"deriving Eq\" geq :: Data a => a -> a -> Bool {- Testing for equality of two terms goes like this. Firstly, we establish the equality of the two top-level datatype constructors. Secondly, we use a twin gmap combinator, namely tgmapQ, to compare the two lists of immediate subterms. (Note for the experts: the type of the worker geq' is rather general but precision is recovered via the restrictive type of the top-level operation geq. The imprecision of geq' is caused by the type system's unability to express the type equivalence for the corresponding couples of immediate subterms from the two given input terms.) -} geq x0 y0 = geq' x0 y0 where geq' :: GenericQ (GenericQ Bool) geq' x y = (toConstr x == toConstr y) && and (gzipWithQ geq' x y) -- | Generic zip controlled by a function with type-specific branches gzip :: GenericQ (GenericM Maybe) -> GenericQ (GenericM Maybe) -- See testsuite/.../Generics/gzip.hs for an illustration gzip f = go where go :: GenericQ (GenericM Maybe) go x y = f x y `orElse` if toConstr x == toConstr y then gzipWithM go x y else Nothing -- | Generic comparison: an alternative to \"deriving Ord\" gcompare :: Data a => a -> a -> Ordering gcompare = gcompare' where gcompare' :: (Data a, Data b) => a -> b -> Ordering gcompare' x y = let repX = constrRep $ toConstr x repY = constrRep $ toConstr y in case (repX, repY) of (AlgConstr nX, AlgConstr nY) -> nX `compare` nY `mappend` mconcat (gzipWithQ gcompare' x y) (IntConstr iX, IntConstr iY) -> iX `compare` iY (FloatConstr rX, FloatConstr rY) -> rX `compare` rY (CharConstr cX, CharConstr cY) -> cX `compare` cY _ -> error "type incompatibility in gcompare" syb-0.7.1/src/Data/Generics/Basics.hs0000644000000000000000000000152113501121711015430 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Basics -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell. -- See . This module provides -- the 'Data' class with its primitives for generic programming, -- which is now defined in @Data.Data@. Therefore this module simply -- re-exports @Data.Data@. -- ----------------------------------------------------------------------------- module Data.Generics.Basics ( module Data.Data ) where import Data.Data