Commit 6823361b authored by ralf's avatar ralf
Browse files

[project @ 2003-11-23 12:29:30 by ralf]

Added and revised test cases.
parent 1def1357
......@@ -41,11 +41,11 @@ clean:
rm -f gmapQ-assoc
rm -f gread
rm -f gshow/gshow
rm -f gsize
rm -f gzip/gzip
rm -f local-quantors
rm -f newtype
rm -f paradise/paradise
rm -f reify/reify
rm -f shortcut
rm -f strings/strings
rm -f where
......@@ -5,5 +5,4 @@ test('nested-datatypes', normal, compile, [''])
test('shortcut', normal, compile, [''])
test('local-quantors', normal, compile, [''])
test('gread', normal, compile_and_run, [''])
test('gsize', normal, compile_and_run, [''])
test('foldTree', normal, compile_and_run, [''])
......@@ -166,7 +166,7 @@ readBin = result
result = if not (max == 0)
then do bin <- readB (lengthNat (max - 1))
gunfoldM (bin2con bin) readBin
gunfoldR (bin2con bin) readBin
else do str <- readBin
con <- str2con (map (chr . bin2nat) str)
......
{-# OPTIONS -fglasgow-exts #-}
module Main where
import Data.Generics
import Data.Maybe
import Control.Monad.State
-- Sample datatypes
data T1 = T1a deriving (Typeable, Data) -- just a constant
data T2 = T2 T1 deriving (Typeable, Data) -- little detour
data T3 = T3a T2 | T3b T3 deriving (Typeable, Data) -- recursive case
data T4 = T4 T3 T3 deriving (Typeable, Data) -- sum matters
-- Purely side-effecting fold over lists
void :: Monad m => (a -> m ()) -> [a] -> m ()
void f = foldM (\() x -> f x) ()
-- Purely side-effecting fold over immediate subterms
gvoid :: (Data a, Monad m) => (forall a. Data a => a -> m ()) -> a -> m ()
gvoid f = unV . gfoldl (\c x -> V (unV c >>= \() -> f x))
(const (V (return ())))
-- The void and phantom type constructor
newtype V m a = V { unV :: m () }
-- Type arguments to stipulate use of undefineds
type TypeArg a = a -> ()
typeArg :: TypeArg a
typeArg = const ()
-- Sample type arguments
t1 = typeArg :: TypeArg T1
t2 = typeArg :: TypeArg T2
t3 = typeArg :: TypeArg T3
t4 = typeArg :: TypeArg T4
-- To force two types to be the same;
-- or to construct a type argument
--
testType :: a -> TypeArg a
testType _ = const ()
-- Extend a type function
extTypeFun :: (Data a, Typeable r) => GTypeFun r -> TypeFun a r -> GTypeFun r
extTypeFun f = maybe f id . cast
-- Data structure for collecting information about types
data Type t c = Type
{ perType :: GTypeFun t
, perConstr :: GTypeFun (Constr -> c)
}
{-
The size of types as the smallest size among its constructors;
the size of constructors as the sum of its component sizes;
we use Maybe Int as sizes where Nothing means pessimistic infinity
to cope with the case that the size is not known yet;
we also flag each type with a Bool to block descent (True).
-}
type GSize = Type (Bool, Maybe Int) (Maybe Int)
-- A completely undefined (say, initial) size structure
isize = Type { perType = const (False, Nothing)
, perConstr = const $ const Nothing
}
-- The transitive-closure function to determine the size of a type
gsize :: GTypeFun (State GSize ())
gsize (ta::a->())
= do
s <- get
( if or [ isJust $ snd $ perType s ta -- size known
, fst $ perType s ta -- descent blocked
]
then return ()
else
( do
flagType True
stepType
flagType False
gsize ta ) )
where
-- Block a type for further descent
flagType :: Bool -> State GSize ()
flagType f
= do s <- get
put $ s { perType = perType s
`extTypeFun`
( \(_::a->()) -> ( f, snd $ perType s ta ) ) }
-- the constructors for the type at hand
cons = dataTypeCons (dataTypeOf (undefinedType ta))
-- The step function which folds over the constructors
stepType :: State GSize ()
stepType
= do void stepConstr cons
s <- get
resizeType $ minConstrs (perConstr s ta) cons
-- Modify size of a type
resizeType :: Maybe Int -> State GSize ()
resizeType size
= do s <- get
put $ s { perType = perType s
`extTypeFun`
( \(_::a->()) -> ( fst $ perType s ta, size ) ) }
-- Determine minimum among the sizes of constructors
minConstrs :: (Constr -> Maybe Int) -> [Constr] -> Maybe Int
minConstrs f = foldr (minJust . f) Nothing
-- The step function which processes a given constructor
stepConstr :: Constr -> State GSize ()
stepConstr c
= do gvoid (stepComp . testType) term
s <- get
resizeConstr $ sumComps s
where
-- Term constructed from c
term = withType (fromConstr c) ta
-- Modify size of a constructor
resizeConstr :: Maybe Int -> State GSize ()
resizeConstr size
= do s <- get
put $ s { perConstr = perConstr s
`extTypeFun`
( \(_::a->()) c' ->
if c==c'
then size
else perConstr s ta c' ) }
-- Compute constructor size as sum of component sizes + 1
sumComps :: GSize -> Maybe Int
sumComps s = foldr addJust (Just 1)
$ gmapQ (snd . perType s . testType) term
-- The step function which processes a given component
stepComp :: GTypeFun (State GSize ())
stepComp = gsize
-- Minimum on maybes with Nothing representing infinite
minJust (Just x) (Just y) = Just (min x y)
minJust x Nothing = x
minJust Nothing x = x
-- Cantor's addition
addJust (Just x) (Just y) = Just (x + y)
addJust _ _ = Nothing
-- Query size of some datatypes
main = print $ ( sizeOfType t1
, sizeOfType t2
, sizeOfType t3
, sizeOfType t4
)
where
sizeOfType ta = fromJust
$ snd
$ perType (snd (runState (gsize ta) isize)) ta
{-# OPTIONS -fglasgow-exts #-}
module CompanyDatatypes where
import Data.Generics hiding (Unit)
-- 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, 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) []
{-# OPTIONS -fglasgow-exts #-}
{-
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.
-}
module Main where
import Data.Maybe
import Data.Generics
import Control.Monad.State
import CompanyDatatypes
-- Build a shallow term
shallowTerm :: GenericR Maybe -> GenericB
shallowTerm cust
=
maybe gdefault id cust
where
-- The worker, also used for type disambiguation
gdefault = case con of
Just (con, Just _) -> gunfoldB con (shallowTerm cust)
_ -> error "no shallow term!"
-- The type to be constructed
typeVal = val2type gdefault
-- The most shallow constructor if any
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
test1 = t1 `reachableType` t2
test2 = t2 `reachableType` t1
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
main = print $ ( test0
, ( test1
, ( test2
, ( test3
, ( test4
, ( test5
, ( test6
, ( test7
, ( test8
, ( test9
, ( test10
)))))))))))
(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)) []))))))))))
test( 'reify',
normal,
multimod_compile_and_run,
['Main','']
)
......@@ -26,7 +26,7 @@ import Data.Generics.Reify
everywhere1RT' :: (Data a, Data b) => (a -> a) -> b -> b
everywhere1RT' f t =
if not $ typeReachableFrom (argType f) (typeValOf t)
if not $ reachableType (argType f) (val2type t)
then t
else gmapT (everywhere1RT' f) (mkT f t)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment