diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,9 @@ +# 0.7.3 + +- Fix `gread` to recognize negative numbers (https://github.com/dreixel/syb/issues/13) +- Bump minimum required GHC to 8.0 +- `Generic'` is now a newtype instead of data, add `GenericR'` and `GenericB'` (https://github.com/dreixel/syb/issues/49) + # 0.7.2.4 - Improved documentation (thanks to @BinderDavid) - Export `ext2` function which was already defined but not exported diff --git a/src/Data/Generics/Aliases.hs b/src/Data/Generics/Aliases.hs --- a/src/Data/Generics/Aliases.hs +++ b/src/Data/Generics/Aliases.hs @@ -51,8 +51,10 @@ GenericM'(..), -- ** Readers GenericR, + GenericR'(..), -- ** Builders GenericB, + GenericB'(..), -- ** Other Generic, Generic'(..), @@ -486,6 +488,12 @@ -- @since 0.1.0.0 type GenericB = forall a. Data a => a +-- | The type synonym `GenericB` has a polymorphic type, and can therefore not +-- appear in places where monomorphic types are expected, for example in a list. +-- The data type `GenericB'` wraps `GenericB` in a data type to lift this restriction. +-- +-- @since 0.7.3 +newtype GenericB' = GenericB' { unGenericB' :: GenericB } -- | Generic readers, say monadic builders, -- i.e., produce an \"a\" with the help of a monad \"m\". @@ -493,6 +501,12 @@ -- @since 0.1.0.0 type GenericR m = forall a. Data a => m a +-- | The type synonym `GenericR` has a polymorphic type, and can therefore not +-- appear in places where monomorphic types are expected, for example in a list. +-- The data type `GenericR'` wraps `GenericR` in a data type to lift this restriction. +-- +-- @since 0.7.3 +newtype GenericR' m = GenericR' { unGenericR' :: GenericR m } -- | The general scheme underlying generic functions -- assumed by gfoldl; there are isomorphisms such as @@ -507,7 +521,7 @@ -- The data type `Generic'` wraps `Generic` in a data type to lift this restriction. -- -- @since 0.1.0.0 -data Generic' c = Generic' { unGeneric' :: Generic c } +newtype Generic' c = Generic' { unGeneric' :: Generic c } ------------------------------------------------------------------------------ -- diff --git a/src/Data/Generics/Text.hs b/src/Data/Generics/Text.hs --- a/src/Data/Generics/Text.hs +++ b/src/Data/Generics/Text.hs @@ -39,13 +39,13 @@ ------------------------------------------------------------------------------ --- | Generic show: an alternative to \"deriving Show\" +-- | Generic 'show': an alternative to @deriving@ 'Show'. -- -- @since 0.1.0.0 gshow :: Data a => a -> String gshow x = gshows x "" --- | Generic shows +-- | Generic 'shows'. -- -- @since 0.2 gshows :: Data a => a -> ShowS @@ -60,7 +60,7 @@ ) `extQ` (shows :: String -> ShowS) --- | Generic read: an alternative to \"deriving Read\" +-- | Generic 'reads' (not 'read'): an alternative to @deriving@ 'Read'. -- -- @since 0.1.0.0 gread :: Data a => ReadS a @@ -127,6 +127,7 @@ string "[]" -- Compound lexeme "[]" <++ string "()" -- singleton "()" <++ infixOp -- Infix operator in parantheses + <++ negativeNumber -- prefix "-" and number literal <++ hsLex -- Ordinary constructors and literals -- Handle infix operators such as (:) @@ -135,3 +136,9 @@ str <- munch1 (not . (==) ')') c2 <- char ')' return $ [c1] ++ str ++ [c2] + + -- Handle negative number literals + negativeNumber :: ReadP String + negativeNumber = do c1 <- char '-' + str <- hsLex + return $ c1 : str diff --git a/src/Data/Generics/Twins.hs b/src/Data/Generics/Twins.hs --- a/src/Data/Generics/Twins.hs +++ b/src/Data/Generics/Twins.hs @@ -16,6 +16,8 @@ -- ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} + module Data.Generics.Twins ( -- * Generic folds and maps that also accumulate @@ -45,18 +47,15 @@ #ifdef __HADDOCK__ import Prelude #endif +import Control.Applicative (Const(..)) import Data.Data import Data.Generics.Aliases +import Data.Functor.Identity (Identity(..)) #ifdef __GLASGOW_HASKELL__ import Prelude hiding ( GT ) #endif -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative (Applicative(..)) -import Data.Monoid ( mappend, mconcat ) -#endif - ------------------------------------------------------------------------------ @@ -106,11 +105,12 @@ => (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) + in (a1, runIdentity d1) where - k a (ID c) d = let (a',d') = f a d - in (a', ID (c d')) - z a x = (a, ID x) + k a (Identity c) d = + let (a',d') = f a d + in (a', Identity (c d')) + z a x = (a, Identity x) -- | Applicative version @@ -153,11 +153,12 @@ -> (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) + in (a1, getConst r1) where - k a (CONST c) d = let (a', r) = f a d - in (a', CONST (c `o` r)) - z a _ = (a, CONST r0) + 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 @@ -193,14 +194,6 @@ ------------------------------------------------------------------------------ --- | 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 } @@ -216,12 +209,15 @@ -- | Twin map for transformation -- -- @since 0.1.0.0 -gzipWithT :: GenericQ (GenericT) -> GenericQ (GenericT) +gzipWithT :: GenericQ GenericT -> GenericQ GenericT gzipWithT f x y = case gmapAccumT perkid funs y of ([], c) -> c _ -> error "gzipWithT" where + perkid :: Data b => [GenericT'] -> b -> ([GenericT'], b) perkid a d = (tail a, unGT (head a) d) + + funs :: [GenericT'] funs = gmapQ (\k -> GT (f k)) x @@ -241,12 +237,14 @@ -- | Twin map for queries -- -- @since 0.1.0.0 -gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r]) +gzipWithQ :: forall r. GenericQ (GenericQ r) -> GenericQ (GenericQ [r]) gzipWithQ f x y = case gmapAccumQ perkid funs y of ([], r) -> r _ -> error "gzipWithQ" where + perkid :: Data c => [GenericQ' b] -> c -> ([GenericQ' b], b) perkid a d = (tail a, unGQ (head a) d) + funs :: [GenericQ' r] funs = gmapQ (\k -> GQ (f k)) x diff --git a/syb.cabal b/syb.cabal --- a/syb.cabal +++ b/syb.cabal @@ -1,5 +1,5 @@ name: syb -version: 0.7.2.4 +version: 0.7.3 license: BSD3 license-file: LICENSE author: Ralf Lammel, Simon Peyton Jones, Jose Pedro Magalhaes @@ -20,22 +20,19 @@ build-type: Simple cabal-version: >= 1.10 tested-with: - GHC == 9.6.1 - GHC == 9.4.4 - GHC == 9.2.7 - GHC == 9.0.2 - GHC == 8.10.7 - GHC == 8.8.4 - GHC == 8.6.5 - GHC == 8.4.4 - GHC == 8.2.2 - GHC == 8.0.2 - GHC == 7.10.3 - GHC == 7.8.4 - GHC == 7.6.3 - GHC == 7.4.2 - GHC == 7.2.2 - GHC == 7.0.4 + GHC == 9.12 + GHC == 9.10 + GHC == 9.8 + GHC == 9.6 + GHC == 9.4 + GHC == 9.2 + GHC == 9.0 + GHC == 8.10 + GHC == 8.8 + GHC == 8.6 + GHC == 8.4 + GHC == 8.2 + GHC == 8.0 extra-source-files: README.md, Changelog.md @@ -47,7 +44,7 @@ Library hs-source-dirs: src default-language: Haskell98 - build-depends: base >= 4.0 && < 5.0 + build-depends: base >= 4.9 && < 5 exposed-modules: Data.Generics Data.Generics.Basics Data.Generics.Instances @@ -66,10 +63,7 @@ Generics.SYB.Twins Generics.SYB.Builders - if impl(ghc < 6.12) - ghc-options: -package-name syb - - ghc-options: -Wall + ghc-options: -Wall -Wcompat test-suite unit-tests type: exitcode-stdio-1.0 diff --git a/tests/Builders.hs b/tests/Builders.hs --- a/tests/Builders.hs +++ b/tests/Builders.hs @@ -1,18 +1,17 @@ module Builders (tests) where --- Testing Data.Generics.Builders functionality - import Test.Tasty.HUnit -import Data.Data import Data.Generics.Builders -- Main function for testing +tests :: Assertion tests = ( constrs :: [Maybe Int] , constrs :: [String] , constrs :: [Either Int Double] , constrs :: [((), Integer)] ) @=? output +output :: ([Maybe Int], [String], [Either Int Double], [((), Integer)]) output = ([Nothing,Just 0],["","\NUL"],[Left 0,Right 0.0],[((),0)]) diff --git a/tests/Ext1.hs b/tests/Ext1.hs --- a/tests/Ext1.hs +++ b/tests/Ext1.hs @@ -14,22 +14,12 @@ import Data.Generics import GHC.Exts (unsafeCoerce#) -#if MIN_VERSION_base(4,8,0) -import GHC.Base hiding(foldr) -#else -import GHC.Base -#endif +import GHC.Base hiding (foldr) -- 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) @@ -44,7 +34,11 @@ -- Test extListQ' foo1 :: Data d => d -> Int foo1 = const 0 `extListQ'` length + +t1 :: Int t1 = foo1 True -- should count as 0 + +t2 :: Int t2 = foo1 [True,True] -- should count as 2 @@ -66,7 +60,10 @@ list :: Data a => [a] -> Int list l = foldr (+) 0 $ map glength l +t3 :: Int t3 = foo2 (True,True) -- should count as 0 + +t4 :: Int t4 = foo2 [(True,True),(True,True)] -- should count as 2+2=4 @@ -76,7 +73,10 @@ then foldr (+) 0 $ gmapListQ glength x else 0 +t5 :: Int t5 = foo3 (True,True) -- should count as 0 + +t6 :: Int t6 = foo3 [(True,True),(True,True)] -- should count as 2+2=4 @@ -107,18 +107,8 @@ 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 :: Assertion tests = ( t1 , ( t2 , ( t3 @@ -127,4 +117,5 @@ , ( t6 )))))) @=? output +output :: (Int, (Int, (Int, (Int, (Int, Int))))) output = (0,(2,(0,(4,(0,4))))) diff --git a/tests/GRead.hs b/tests/GRead.hs --- a/tests/GRead.hs +++ b/tests/GRead.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} - module GRead (tests) where {- @@ -16,30 +14,42 @@ 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 ++ ")" +str1, str2, str3, str4, str4a, str5, str6, str7 :: String +str1 = "(True)" -- reads fine as a Bool +str2 = "(Treu)" -- invalid constructor +str3 = "True" -- lacks parentheses +str4 = "(1)" -- could be an Int +str4a = "(-1)" -- negative literal +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 +expected :: + ( [[(Bool, String)]] + , [[(Int, String)]] + , [[([Int], String)]] + ) +expected = + ( [ gread str1, + gread str2, + gread str3 + ] + , [ gread str4, + gread str4a, + gread str5 + ] + , [ gread str6, + gread str7 + ] + ) -output = show - ([[(True,"")],[],[]],[[(1,"")],[(2,"...")]],[[([],"")],[([1],"")]]) +tests :: Assertion +tests = show expected @=? show output + +output :: + ( [[(Bool, String)]] + , [[(Int, String)]] + , [[([Int], String)]] + ) +output = + ([[(True,"")],[],[]],[[(1,"")],[(-1,"")],[(2,"...")]],[[([],"")],[([1],"")]]) diff --git a/tests/GenUpTo.hs b/tests/GenUpTo.hs --- a/tests/GenUpTo.hs +++ b/tests/GenUpTo.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} + module GenUpTo (tests) where {- @@ -25,27 +27,27 @@ -} data Prog = Prog Dec Stat - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) data Dec = Nodec | Ondec Id Type | Manydecs Dec Dec - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) data Id = A | B - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) data Type = Int | Bool - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) data Stat = Noop | Assign Id Exp | Seq Stat Stat - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) data Exp = Zero | Succ Exp - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) -- Generate all terms of a given depth @@ -70,20 +72,22 @@ -- cons' :: [Constr] cons' = case dataTypeRep ty of - AlgRep cons -> cons - IntRep -> [mkIntegralConstr ty 0] - FloatRep -> [mkIntegralConstr ty 0] - CharRep -> [mkCharConstr ty 'x'] + AlgRep cons'' -> cons'' + IntRep -> [mkIntegralConstr ty 0] + FloatRep -> [mkIntegralConstr ty 0] + CharRep -> [mkCharConstr ty 'x'] + NoRep -> [] 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) +data T0 = T0 T1 T2 T3 deriving (Show, Eq, Data) +data T1 = T1a | T1b deriving (Show, Eq, Data) +data T2 = T2a | T2b deriving (Show, Eq, Data) +data T3 = T3a | T3b deriving (Show, Eq, Data) +tests :: Assertion tests = ( genUpTo 0 :: [Id] , ( genUpTo 1 :: [Id] , ( genUpTo 2 :: [Id] @@ -91,4 +95,5 @@ , ( genUpTo 3 :: [Prog] ))))) @=? output +output :: ([a], ([Id], ([Id], ([T0], [Prog])))) 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)])))) diff --git a/tests/HList.hs b/tests/HList.hs --- a/tests/HList.hs +++ b/tests/HList.hs @@ -26,19 +26,6 @@ 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 @@ -47,16 +34,19 @@ ---------------------------------------------------------------------------- -- A demo list +mylist :: HList mylist = addHList (1::Int) $ addHList (True::Bool) $ addHList ("42"::String) $ initHList -- Main function for testing +tests :: Assertion 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 :: (String, (String, (String, String))) output = ("Just 1",("Nothing",("Just True","Just \"42\""))) diff --git a/tests/Perm.hs b/tests/Perm.hs --- a/tests/Perm.hs +++ b/tests/Perm.hs @@ -13,7 +13,7 @@ import Test.Tasty.HUnit -import Control.Applicative (Alternative(..), Applicative(..)) +import Control.Applicative (Alternative(..)) import Control.Monad import Data.Generics @@ -21,9 +21,9 @@ -- 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) +data T1 = T1 deriving (Show, Eq, Data) +data T2 = T2 deriving (Show, Eq, Data) +data T3 = T3 T1 T2 deriving (Show, Eq, Data) --------------------------------------------------------------------------- @@ -36,15 +36,16 @@ -- Run a computation +runReadT :: ReadT a -> [String] -> Maybe a runReadT x y = case unReadT x y of - Just ([],y) -> Just y + Just ([],z) -> Just z _ -> Nothing -- Read one string readT :: ReadT String -readT = ReadT (\x -> if null x - then Nothing - else Just (tail x, head x) +readT = ReadT (\x -> case x of + [] -> Nothing + y : ys -> Just (ys, y) ) instance Functor ReadT where @@ -99,7 +100,7 @@ -- Determine type of data to be constructed myType = myTypeOf result where - myTypeOf :: forall a. ReadT a -> a + myTypeOf :: forall b. ReadT b -> b myTypeOf = undefined -- Turn string into constructor @@ -108,11 +109,11 @@ (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)) + buildT' :: forall b. Data b => b -> GenM + buildT' (_::b) = GenM (const mzero `extM` const (buildT::ReadT b)) -- The permutation exploration function - perm :: forall a. Data a => [GenM] -> [GenM] -> a -> ReadT a + perm :: forall b. Data b => [GenM] -> [GenM] -> b -> ReadT b perm [] [] a = return a perm fs [] a = perm [] fs a perm fs (f:fs') a = ( @@ -130,6 +131,7 @@ -- The main function for testing --------------------------------------------------------------------------- +tests :: Assertion tests = ( runReadT buildT ["T1"] :: Maybe T1 -- should parse fine , ( runReadT buildT ["T2"] :: Maybe T2 -- should parse fine @@ -138,4 +140,5 @@ , ( runReadT buildT ["T3","T2","T2"] :: Maybe T3 -- should fail ))))) @=? output +output :: (Maybe T1, (Maybe T2, (Maybe T3, (Maybe T3, Maybe a)))) output = (Just T1,(Just T2,(Just (T3 T1 T2),(Just (T3 T1 T2),Nothing)))) diff --git a/tests/Tree.hs b/tests/Tree.hs --- a/tests/Tree.hs +++ b/tests/Tree.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} + module Tree (tests) where {- @@ -12,7 +14,6 @@ import Test.Tasty.HUnit import Control.Monad (guard) -import Control.Monad.Reader import Data.Generics import Data.Maybe import Data.Tree @@ -49,16 +50,18 @@ perkid ts = const (tail ts, tree2data (head ts)) -- recurse into kids - kids x = - do guard (glength x == length ts) - snd (gmapAccumM perkid ts x) + kids y = + do guard (glength y == length ts) + snd (gmapAccumM perkid ts y) -- Main function for testing +tests :: Assertion tests = ( genCom , ( data2tree genCom , ( (tree2data (data2tree genCom)) :: Maybe Company , ( Just genCom == tree2data (data2tree genCom) )))) @=? output +output :: (Company, (Tree String, (Maybe Company, Bool))) 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))) diff --git a/tests/XML.hs b/tests/XML.hs --- a/tests/XML.hs +++ b/tests/XML.hs @@ -14,23 +14,22 @@ import Test.Tasty.HUnit -import Control.Applicative (Alternative(..), Applicative(..)) +import Control.Applicative (Alternative(..)) 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) + deriving (Show, Eq, Data) data Content = CElem Element | CString Bool CharData -- ^ bool is whether whitespace is significant | CRef Reference | CMisc Misc - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) type CharData = String @@ -84,7 +83,7 @@ -- Determine type of data to be constructed myType = myTypeOf result where - myTypeOf :: forall a. ReadX a -> a + myTypeOf :: forall b. ReadX b -> b myTypeOf = undefined -- Handle an element @@ -98,7 +97,7 @@ -- A special case for lists - list :: forall a. Data a => ReadX [a] + list :: forall b. Data b => ReadX [b] list = ( do h <- content2data t <- list return (h:t) ) @@ -148,15 +147,16 @@ -> Maybe ([Content], a) } -- Run a computation +runReadX :: ReadX a -> [Content] -> Maybe a runReadX x y = case unReadX x y of - Just ([],y) -> Just y + Just ([],z) -> Just z _ -> Nothing -- Read one content particle readX :: ReadX Content -readX = ReadX (\x -> if null x - then Nothing - else Just (tail x, head x) +readX = ReadX (\x -> case x of + [] -> Nothing + y : ys -> Just (ys, y) ) instance Functor ReadX where @@ -194,6 +194,7 @@ -- ----------------------------------------------------------------------------- +tests :: Assertion tests = ( genCom , ( data2content genCom , ( zigzag person1 :: Maybe Person @@ -205,4 +206,5 @@ zigzag :: Data a => a -> Maybe a zigzag = runReadX content2data . data2content +output :: (Company, ([Content], (Maybe Person, (Maybe Company, Bool)))) 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))))