syb 0.7.2.4 → 0.7.3
raw patch · 13 files changed
+176/−154 lines, 13 filesdep ~base
Dependency ranges changed: base
Files
- Changelog.md +6/−0
- src/Data/Generics/Aliases.hs +15/−1
- src/Data/Generics/Text.hs +10/−3
- src/Data/Generics/Twins.hs +21/−23
- syb.cabal +16/−22
- tests/Builders.hs +2/−3
- tests/Ext1.hs +13/−22
- tests/GRead.hs +37/−27
- tests/GenUpTo.hs +19/−14
- tests/HList.hs +3/−13
- tests/Perm.hs +15/−12
- tests/Tree.hs +7/−4
- tests/XML.hs +12/−10
Changelog.md view
@@ -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
src/Data/Generics/Aliases.hs view
@@ -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 } ------------------------------------------------------------------------------ --
src/Data/Generics/Text.hs view
@@ -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
src/Data/Generics/Twins.hs view
@@ -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
syb.cabal view
@@ -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
tests/Builders.hs view
@@ -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)])
tests/Ext1.hs view
@@ -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)))))
tests/GRead.hs view
@@ -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],"")]])
tests/GenUpTo.hs view
@@ -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)]))))
tests/HList.hs view
@@ -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\"")))
tests/Perm.hs view
@@ -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))))
tests/Tree.hs view
@@ -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)))
tests/XML.hs view
@@ -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))))