{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
-------------------------------------------------------------------------------
module ShapeSyb ( tests, main_tests ) where
-------------------------------------------------------------------------------
import Test.HUnit
import SAI.Data.Generics.Shape
import Data.Data ( Data, Typeable )
import Data.Generics.Aliases ( mkQ, extQ )
import Data.Generics.Aliases ( GenericQ )
import Data.List ( intersperse )
import Control.Exception ( evaluate )
--import Data.Dynamic
-- Testing abstract datatype:
import qualified Data.Map as Map
import Data.Map ( Map )
--import Debug.Trace ( trace )
import Control.Monad
import Data.Maybe
import System.IO.Unsafe ( unsafePerformIO )
-------------------------------------------------------------------------------
-- Sample types and values (constructor application expressions).
-- Expected structures are shown in parentheses language.
test_list = [[1,2],[3],[4,5,6::Int]]
data TA = A1 | A2 TB TA TB
data TB = B TA
exprAB = A2 (B A1) A1 (B A1)
-- ((())()(()))
data TC = C1 Float (Int,Int) | C2 TD TC TD | C3 TC
data TD = D TC
exprCD = C2 (D (C1 1.1 (4,5))) (C3 (C1 2.2 (6,7))) (D (C1 3.3 (8,9)))
-- (((()(()())))((()(()())))((()(()())))
data TE = E1 String | E2 (Int,Int) TF
data TF = F TE String
exprEF = E2 (2,5) (F (E1 "foo") "bar")
-- ((()(())())()())
-- For testing that Dynamic can recover nodes elided below a node.
data TG = G TH
data TH = H TI
data TI = I
data TJ = J | J1 TJ | J2 TJ | J3 TJ
exprGHI = G (H I) -- multiple types
exprJ = J1 (J2 (J3 J)) -- multiple data constructors
data TK = K1 TL | K2 TM | K3
data TL = L1 | L2 TL | L3 TM
data TM = M1 TL TL | M2 TK
exprKLM = K2 (M1 (L2 L1) (L2 (L3 (M2 K3))))
exprN = Map.fromList [("sfv",2.2),("pdsfhp",3.3),("",1.1)] :: Map String Float
-- requires -XStandaloneDeriving (this isn't really what it's for...)
deriving instance Data TA ; deriving instance Typeable TA
deriving instance Data TB ; deriving instance Typeable TB
deriving instance Data TC ; deriving instance Typeable TC
deriving instance Data TD ; deriving instance Typeable TD
deriving instance Data TE ; deriving instance Typeable TE
deriving instance Data TF ; deriving instance Typeable TF
deriving instance Data TG ; deriving instance Typeable TG
deriving instance Data TH ; deriving instance Typeable TH
deriving instance Data TI ; deriving instance Typeable TI
deriving instance Data TJ ; deriving instance Typeable TJ
deriving instance Data TK ; deriving instance Typeable TK
deriving instance Data TL ; deriving instance Typeable TL
deriving instance Data TM ; deriving instance Typeable TM
-- often you would not have any Show instance for your
-- source types, but here it's useful for preparing
-- my writeup...
deriving instance Show TA
deriving instance Show TB
deriving instance Show TC
deriving instance Show TD
deriving instance Show TE
deriving instance Show TF
deriving instance Show TG
deriving instance Show TH
deriving instance Show TI
deriving instance Show TJ
deriving instance Show TK
deriving instance Show TL
deriving instance Show TM
-------------------------------------------------------------------------------
-- Target type for some of the homomorphisms exercised.
-- Typeable for Hetero/Bi which use Data.Dynamic.
-- Eq used to be needed for filterHomo etc. but not anymore.
data Result = Result (Int,Int) deriving ( Show, Typeable )
-- A lifted type (Result (Maybe (Int,Int)) would be better)!
dud_result = Result (0,0)
pair_result pair = Result pair
-------------------------------------------------------------------------------
test0 :: TC -> Homo Result
test0 = ghom (mkQ dud_result f)
--test0 = ghom (\r _->r) (mkQ dud_result f)
where
-- This is only generic in the sense that other types
-- will still be traversed (passed over).
-- f :: TC -> Result
f (C1 _ pair) = pair_result pair
f (C2 _ _ d2@(D c)) = let g (Result (x,y)) = Result (y,x) in g (f c)
-- f (C2 _ _ d2@(D c)) = f c -- line above is more interesting
f x = dud_result -- still needed! (notwithstanding mkQ)
-- f x = x
#if 0
--test1 :: TC -> Homo Result
--test1 = ghomP (mkQ True p) (\r _->r) (mkQ dud_result f)
test1 = ghomP p' (\r _->r) (mkQ dud_result f)
where
f :: TC -> Result -- correct (but unneeded)
--- f :: forall b. Data b => b -> Result -- wrong (we'd like it though)
f (C1 _ pair) = pair_result pair
f (C2 _ _ d2@(D c)) = let g (Result (x,y)) = Result (y,x) in g (f c)
-- f (C2 _ _ d2@(D c)) = f c -- line above is more interesting
f x = dud_result
p :: TC -> Bool -- correct (but unneeded)
--- p :: forall e. (Data e, Typeable e) => e -> Bool -- (would be nice)
p (C1 _ (i1,i2)) = i1 < 7
-- p (C1 _ (i1,i2)) = i1 < i2
-- p (C2 _ _ d2@(D c)) = p c
p x = True
-- one or the other sig. is NEEDED:
-- p' :: forall d. (Data d, Typeable d) => d -> Bool
p' :: GenericQ Bool
-- p' = mkQ True (\x -> p (x :: (forall d. (Data d, Typeable d) => d)))
-- p' = mkQ True (\x -> p (x :: (forall d. (Data d) => d)))
p' = mkQ True p
--mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
--type GenericQ r = forall a. Data a => a -> r
--data TC = C1 Float (Int,Int) | C2 TD TC TD deriving ( Data, Typeable )
--data TD = D TC deriving ( Data, Typeable )
#else
-- It is necessary to have SOME boilerplate in the user code,
-- like "mkQ", because the type system won't let me pass a
-- generically-typed function f to by mkQ'd in callee?
-- It's tempting to just go with k = (\r _->r) internally,
-- were it not for the early precedent of weightedShapeOf...
-- Still, mapping a ()-tree to an Int-tree bearing branch
-- weights is not really in the purview of this mini-project,
-- so, yeah, I'm getting rid of that!... Yay!
-----------
-- Later: needed to make f as a whole return Maybe r...
test1 :: TC -> [Homo Result]
test1 = gfilter (mkQP p f)
where
#if 1
p :: Result -> Bool
p (Result (x,_)) = x < 7
p x = False
#else
p :: TC -> Bool
p (C1 _ (i1,i2)) = i1 < 7
p x = True
#endif
f :: TC -> Maybe Result
-- f :: TC -> Result
f (C1 _ pair)
= Just $ pair_result pair
f (C2 _ _ d2@(D c))
= let g (Just (Result (x,y))) = Just (Result (y,x)) in g (f c)
f x = Nothing
-- f x = dud_result
#endif
test1b :: TC -> Homo Result
test1b = gfilter_ dud_result (mkQP p f)
where
#if 1
p :: Result -> Bool
p (Result (x,_)) = x < 7
p x = False
#else
p :: TC -> Bool
p (C1 _ (i1,i2)) = i1 < 7
p x = True
#endif
f :: TC -> Maybe Result
-- f :: TC -> Result
f (C1 _ pair)
= Just $ pair_result pair
f (C2 _ _ d2@(D c))
= let g (Just (Result (x,y))) = Just (Result (y,x)) in g (f c)
f x = Nothing
-- f x = dud_result
#if 0
test1' :: TC -> Homo Result
test1' = ghomP' p (mkQ dud_result f)
where
-- f :: forall d. Data d => d -> Result
f (C1 _ pair) = pair_result pair
f (C2 _ _ d2@(D c)) = let g (Result (x,y)) = Result (y,x) in g (f c)
-- f (C2 _ _ d2@(D c)) = f c -- line above is more interesting
f x = dud_result
-- f x = x
-- p :: Homo Result -> Bool
-- p (R (Result (x,y)) _) = not $ x == 0 && y == 0
p :: Result -> Bool
p (Result (x,y)) = not $ x == 0 && y == 0
#endif
test2 :: TC -> Homo Result
test2 = ghom ((const dud_result) `extQ` fTC `extQ` fTD)
where
fTC :: TC -> Result
fTC (C1 _ pair) = pair_result pair
-- Note we don't need to cover all the cases, or provide a base case;
-- SYB provides the default case for us automatically.
fTC x = dud_result
-- fTC x = x
fTD :: TD -> Result
fTD (D c) = Result (1,1)
-- fTD (D c) = (mkQ (const dud_result) fTC) c -- why not?
-- fTD (D c) = fTC c -- risk non-exhaustive patterns runtime errpr
fTD x = dud_result
-- fTD x = x
---------------------------------------
data CompanyType = Company [DepartmentType]
data DepartmentType = Department String ManagerType [EmployeeType]
data ManagerType = Manager { rank :: Float
, manName :: String
, manSalary :: SalaryType }
data EmployeeType = Employee { empName :: String
, empSalary :: SalaryType }
data SalaryType = Salary Float
deriving instance Data CompanyType ; deriving instance Typeable CompanyType
deriving instance Data DepartmentType ; deriving instance Typeable DepartmentType
deriving instance Data ManagerType ; deriving instance Typeable ManagerType
deriving instance Data EmployeeType ; deriving instance Typeable EmployeeType
deriving instance Data SalaryType ; deriving instance Typeable SalaryType
deriving instance Show CompanyType
deriving instance Show DepartmentType
deriving instance Show ManagerType
deriving instance Show EmployeeType
deriving instance Show SalaryType
data NiceRecord = NiceHole
| NiceRecord { nice_name :: String
, nice_salary :: Int }
deriving ( Show )
isNiceHole NiceHole = True
isNiceHole _ = False
------------------------------
-- small, one department retail company
company1 = Company [Department "Sales" (Manager 1 "Deborah" (Salary 75000)) [Employee "Jane" (Salary 35000)]]
--test4 :: EmployeeType -> Homo NiceRecord
--test4 :: forall d. Data d => d -> Homo NiceRecord
test4 = ghom (const NiceHole `extQ` f_EmployeeType `extQ` f_ManagerType)
--test4 = ghom f
where
-- No sum types involved, so no explicit defaults
-- needed (unlike in previous examples).
f_EmployeeType (Employee name (Salary salary))
= NiceRecord name (floor salary)
f_ManagerType (Manager _ name _)
= NiceRecord name 0
test5 :: [[Int]] -> [[Maybe Bool]]
test5 = map (map (\x ->if odd x then Just True else Nothing))
-----------------------------------
#if 1
-- XXX This is now a hack; I'm only trying to make my
-- executable "test-sai-shape-syb" (test-05.hs) instead
-- work as unit-tests in cabal; the sole reason being,
-- to prevent building it every rebuild, as building
-- this and linking it takes like 20 seconds!...
main_tests :: IO Int
main_tests = do
#if 1
-- When developing SYB code, it can matter whether or
-- not your functions are used -- if they're not demanded,
-- you may get (compile-time) type errors requiring explicit
-- type signatures. This can be prevented by creating
-- artificial demand thus:
evaluate (test4 company1)
#endif
putStrLn $ concat $ intersperse "\n" [ ""
, "> show test_list\n "
, show test_list ++ "\n"
, "> showHomo $ shapeOf test_list\n "
, showHomo $ shapeOf test_list
, "> showAsParens $ shapeOf test_list\n "
, (showAsParens $ shapeOf test_list) ++ "\n"
, "> showAsParensBool $ ghom (mkQ False (odd::Int->Bool)) test_list\n "
, (showAsParensBool $ ghom (mkQ False (odd::Int->Bool)) test_list) ++ "\n"
, "> showAsParensEnriched $ ghom (mkQ False (odd::Int->Bool)) test_list\n "
, (showAsParensEnriched $ ghom (mkQ False (odd::Int->Bool)) test_list) ++ "\n"
, "> showHomo $ ghom (mkQ False (odd::Int->Bool)) test_list\n "
, showHomo $ ghom (mkQ False (odd::Int->Bool)) test_list
, "> showHomo $ filterHomo id $ ghom (mkQ False (odd::Int->Bool)) test_list\n "
, showHomo $ filterHomo id $ ghom (mkQ False (odd::Int->Bool)) test_list
, "> showHetero $ ghomDyn test_list\n "
, showHetero $ ghomDyn test_list
, "> showHetero $ filterHetero (/=(3::Int)) $ ghomDyn test_list\n "
, showHetero $ filterHetero (/=(3::Int)) $ ghomDyn test_list
, "> showBi $ heteroToBi False (odd::Int->Bool) $ ghomDyn test_list\n "
, showBi $ heteroToBi False (odd::Int->Bool) $ ghomDyn test_list
#if 1
#if 0
, "> showHomo $ heteroToHomo $ filterHetero (/=3::Int) $ ghomDyn test_list\n "
, showHomo $ heteroToHomo $ filterHetero (/=3::Int) $ ghomDyn test_list
#endif
, "> showBi $ ghomBi (mkQ False (odd::Int->Bool)) test_list\n "
, showBi $ ghomBi (mkQ False (odd::Int->Bool)) test_list
, "> showBi $ filterBi id $ ghomBi (mkQ False (odd::Int->Bool)) test_list\n "
, showBi $ filterBi id $ ghomBi (mkQ False (odd::Int->Bool)) test_list
, "> showHomo $ biToHomo $ filterBi id $ ghomBi (mkQ False (odd::Int->Bool)) test_list\n "
, showHomo $ biToHomo $ filterBi id $ ghomBi (mkQ False (odd::Int->Bool)) test_list
, "> let f (x::Int) = if odd x then Just x else Nothing\n"
, "> showHomo $ ghom (mkQ Nothing f) test_list\n "
, showHomo $ ghom (mkQ Nothing (\x -> if odd (x::Int) then Just x else Nothing)) test_list
, "> showHomo $ filterHomoMM $ ghom (mkQ Nothing f) test_list\n "
, showHomo $ filterHomoMM $ ghom (mkQ Nothing (\x -> if odd (x::Int) then Just x else Nothing)) test_list
, "> showHomo $ unliftHomoM 0 $ filterHomoMM $ ghom (mkQ Nothing f) test_list\n "
, showHomo $ unliftHomoM 0 $ filterHomoMM $ ghom (mkQ Nothing (\x -> if odd (x::Int) then Just x else Nothing)) test_list
#endif
#if 1
, "> showAsParens $ shapeOf exprAB\n "
, (showAsParens $ shapeOf exprAB) ++ "\n"
, "> showAsParens $ shapeOf exprCD\n "
, (showAsParens $ shapeOf exprCD) ++ "\n"
, "> showAsParens $ shapeOf exprEF\n "
, (showAsParens $ shapeOf exprEF) ++ "\n"
#endif
, "> show $ ( ( unGhomDyn $ ghomDyn exprEF ) :: TE )\n "
, (show $ ( ( unGhomDyn $ ghomDyn exprEF ) :: TE ) ) ++ "\n"
, "> showHomo $ ( gempty exprEF :: BiM Int)\n "
, (showHomo $ ( gempty exprEF :: BiM Int)) ++ "\n"
, "Progressive refinement and accumulation:\n"
#if 1
, "\
> (showHomo $\n\
( grefine\n\
(\\ x -> case x of { E2 (y,z) _ -> Just (z+3)\n\
; _ -> Nothing })\n\
( gempty exprEF :: BiM Int)\n\
)\n\
)\n"
#endif
, (showHomo $
( grefine
(\ x -> case x of { E2 (y,z) _ -> Just (z+3)
; _ -> Nothing })
( gempty exprEF :: BiM Int)
)
)
-- , (showHomo $ ( grefine (\ x -> case x of { (E2 (y,z) _) -> Just (z+3) ; _ -> Nothing }) ( gempty exprEF :: BiM Int))) ++ "\n"
-- , (showHomo $ ( grefine (\ x -> case x of { (E2 (y,z) _) -> z+3 ; _ -> -1 }) ( gempty exprEF :: BiM Int))) ++ "\n" -- works, but...
-- , (showHomo $ ( grefine (\ x -> case x of { (E2 (y,z) _) -> z+3 ; _ -> undefined::Int }) ( gempty exprEF :: BiM Int))) ++ "\n"
-- , (showHomo $ ( grefine (\ (E2 (x,y) _) -> y+3) ( gempty exprEF :: BiM Int))) ++ "\n"
#if 0
-- This is giving me Just 3 at every node (whether source node was TE or TF):
, "> showHomo $ ( grefine (\\x -> 3) ( gempty exprEF :: BiM Int))\n "
, (showHomo $ ( grefine (\(x::TF) -> 3) ( gempty exprEF :: BiM Int))) ++ "\n"
#endif
-- XXX Still can't figure it out...
#if 0
, (showHomo $ ( grefineG (mkQ Nothing ((\ x -> case x of { (E2 (y,z) _) -> Just (z+3) ; _ -> Nothing }) :: TE -> Maybe Int)) ( gempty exprEF :: BiM Int))) ++ "\n"
-- , (showHomo $ ( grefineG (mkQ Nothing ((\ x -> case x of { (E2 (y,z) _) -> Just (z+3) ; _ -> Nothing }) :: TE -> Maybe Int)) ( gempty exprEF :: BiM Int))) ++ "\n"
#endif
#if 0
, "blah\
\foo"
#endif
#if 0
, "foo\
\ bar"
#endif
#if 0
, "foo\
, (showHomo $\
( gaccum\
((\\r1 r2 -> r1+r2) :: Int -> Int -> Int)"
#endif
#if 1
, "\
> (showHomo $\n\
( gaccum\n\
((\\r1 r2 -> r1+r2) :: Int -> Int -> Int)\n\
(\\ x -> case x of { E1 s -> Just (length s)\n\
; _ -> Nothing })\n\
( grefine\n\
(\\ x -> case x of { E2 (y,z) _ -> Just (z+3)\n\
; _ -> Nothing })\n\
( gempty exprEF :: BiM Int)\n\
)\n\
)\n\
)\n"
#endif
, (showHomo $
( gaccum
((\r1 r2 -> r1+r2) :: Int -> Int -> Int)
(\ x -> case x of { E1 s -> Just (length s)
; _ -> Nothing })
( grefine
(\ x -> case x of { E2 (y,z) _ -> Just (z+3)
; _ -> Nothing })
( gempty exprEF :: BiM Int)
)
)
)
, "\nTesting that a Dynamic node can recover nodes elided below it:\n"
, "Testing a chain of types:\n"
, "> let (f::TH->Bool) x = case x of { H _ -> False ; _ -> True }\n"
, "> show exprGHI\n"
, show exprGHI ++ "\n"
, "> showBi $ ghomBi (mkQ True f) exprGHI\n"
, showBi $ ghomBi (mkQ True ( (\ x -> case x of { H _ -> False ; _ -> True }) :: TH -> Bool ) ) exprGHI
, "> showBi $ filterBi id $ ghomBi (mkQ True f) exprGHI\n"
, showBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { H _ -> False ; _ -> True }) :: TH -> Bool ) ) exprGHI
, "> ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True f) exprGHI ) :: TG ) )\n"
, ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { H _ -> False ; _ -> True }) :: TH -> Bool ) ) exprGHI ) :: TG ) ) ++ "\n"
, "Testing a chain of constructors:\n"
, "> show exprJ\n"
, show exprJ ++ "\n"
, "> let (f::TJ->Bool) x = case x of { J1 _ -> False ; J3 _ -> False; _ -> True }\n"
, "> showBi $ ghomBi (mkQ True f) exprJ\n"
, showBi $ ghomBi (mkQ True ( (\ x -> case x of { J1 _ -> False ; J3 _ -> False; _ -> True }) :: TJ -> Bool ) ) exprJ
, "> showBi $ filterBi id $ ghomBi (mkQ True f) exprJ\n"
, showBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { J1 _ -> False ; J3 _ -> False; _ -> True }) :: TJ -> Bool ) ) exprJ
, "> ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True f) exprJ ) :: TJ ) )\n"
, ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { J1 _ -> False ; J3 _ -> False; _ -> True }) :: TJ -> Bool ) ) exprJ ) :: TJ ) ) ++ "\n"
, "Testing a mixture of types and constructors:\n"
, "> show exprKLM\n"
, show exprKLM ++ "\n"
, "> let (f::TL->Bool) x = case x of { L2 _ -> False ; L3 _ -> False; _ -> True }\n"
, "> showBi $ ghomBi (mkQ True f) exprKLM\n"
, showBi $ ghomBi (mkQ True ( (\ x -> case x of { L2 _ -> False ; L3 _ -> False; _ -> True }) :: TL -> Bool ) ) exprKLM
, "> showBi $ filterBi id $ ghomBi (mkQ True f) exprKLM\n"
, showBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { L2 _ -> False ; L3 _ -> False; _ -> True }) :: TL -> Bool ) ) exprKLM
, "> ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True f) exprKLM ) :: TK ) )\n"
, ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { L2 _ -> False ; L3 _ -> False; _ -> True }) :: TL -> Bool ) ) exprKLM ) :: TK ) ) ++ "\n"
, "\nTesting filterHomoM and filterBiM:\n"
, "> show test_list\n"
, show test_list ++ "\n"
, "> showHomo $ filterHomoM odd $ ghom (mkQ 0 (id::Int->Int)) test_list\n"
, showHomo $ filterHomoM odd $ ghom (mkQ 0 (id::Int->Int)) test_list
, "> showBi $ filterBiM odd $ ghomBi (mkQ 0 (id::Int->Int)) test_list\n"
, showBi $ filterBiM odd $ ghomBi (mkQ 0 (id::Int->Int)) test_list
-- , showBi $ filterBiM odd $ ghomBi (mkQ (-1) (id::Int->Int)) test_list
-- is WORKING!...
, "\nTesting abstract datatype:\n"
, "> show exprN\n"
, show exprN ++ "\n"
, "> show $ Map.toList exprN\n"
, (show $ Map.toList exprN) ++ "\n"
, "> showHomo $ shapeOf exprN\n"
, showHomo $ shapeOf exprN
, "> showAsParensEnriched $ shapeOf exprN\n"
, (showAsParensEnriched $ shapeOf exprN) ++ "\n"
, "> showHomo $ ghom (mkQ 0.0 (\\ (x::Float) -> x)) exprN\n"
, showHomo $ ghom (mkQ 0.0 (\ (x::Float) -> x)) exprN
, "> showHomo $ filterHomo (>0.5) $ ghom (mkQ 0.0 (\\ (x::Float) -> x)) exprN\n"
, showHomo $ filterHomo (>0.5) $ ghom (mkQ 0.0 (\ (x::Float) -> x)) exprN
, "> showHomo $ filterHomoM (>0.5) $ ghom (mkQ 0.0 (\\ (x::Float) -> x)) exprN\n"
, showHomo $ filterHomoM (>0.5) $ ghom (mkQ 0.0 (\ (x::Float) -> x)) exprN
#if 0
, "show exprCD\n "
, show exprCD ++ "\n"
, "showHomo $ shapeOf exprCD\n "
, showHomo $ shapeOf exprCD
, "showAsParens $ shapeOf exprCD\n "
, (showAsParens $ shapeOf exprCD) ++ "\n"
, "showHomo $ test0 exprCD\n "
, showHomo $ test0 exprCD
, "concatMap showHomo $ test1 exprCD -- gfilter\n "
, (concatMap showHomo $ test1 exprCD) ++ "\n"
, "showHomo $ test1b exprCD -- gfilter_\n "
, showHomo $ test1b exprCD
, "showHomo $ test2 exprCD\n "
, showHomo $ test2 exprCD
, "showHomo $ filterHomo (\\ (Result (x,y)) -> not $ x == 0 && y == 0 ) $ test2 exprCD\n "
, showHomo $ filterHomo (\ (Result (x,y)) -> not $ x == 0 && y == 0 ) $ test2 exprCD
, "showHomo $ shapeOf exprEF\n "
, showHomo $ shapeOf exprEF
, "show company1\n "
, show company1 ++ "\n"
, "showAsParens $ shapeOf company1\n "
, (showAsParens $ shapeOf company1) ++ "\n"
, "showHomo $ shapeOf company1\n "
, showHomo $ shapeOf company1
, "showHomo $ test4 company1\n "
, showHomo $ test4 company1
, "showHomo $ filterHomo (not . isNiceHole) $ test4 company1\n "
, showHomo $ filterHomo (not . isNiceHole) $ test4 company1
-- , showHomo $ filterHomo (not . isNiceHole) $ shapeOf exprAB -- pointless
#endif
]
#endif
return 0
-------------------------------------------------------------------------------
-- XXX A better way to "fail on purpose" is to have the test
-- return ExitFailure, no?...
--tests = (unsafePerformIO main_tests == output) ~? "FAILING ON PURPOSE TO DISPLAY THE LOGGED OUTPUT!" -- yeah but it wasn't printed
tests = unsafePerformIO
( do n <- main_tests
putStrLn "FAILING ON PURPOSE TO DISPLAY THE LOGGED OUTPUT!\n"
return n )
~=? output
output = 1::Int -- force test to fail! (so we see the output!)
--output = 0::Int
--output = ()
-------------------------------------------------------------------------------