module Problem1.Test where import qualified Control.Monad.State as CMS(StateT, runStateT) import qualified Control.Monad.Error as CME() import Problem1.Types(Err, Value) import Problem1 -- (C(..), BOp(..), UOp(..), NullOp(..), eval) ---------------------------------------------------------------- -- Testing code: -- run' :: CalcM Value -> Either Err Value run' :: (Num s, Monad m) => CMS.StateT s m v -> m v run' mv = do (result, mem) <- CMS.runStateT mv 0 return result -- run :: Calc -> Either Err Value run :: (Fractional v, Monad m) => C v -> m v run = run' . eval ---------------------------------------------------------------- -- Some instances just for fun instance Monad C where return = returnC (>>=) = bindC fail = failC returnC :: a -> C a returnC = Num bindC :: C a -> (a -> C b) -> C b bindC (CBin op e1 e2) f = CBin op (bindC e1 f) (bindC e2 f) bindC (CUn op e) f = CUn op (bindC e f) bindC (CNull op) f = CNull op bindC (Num a) f = f a failC :: String -> C a failC err = error ("failC: "++err) -- a Fail constructor is missing to completely implement the Haskell Monad class instance Num a => Num (C a) where (+) = CBin Add (-) = CBin Sub (*) = CBin Mul fromInteger = Num . fromInteger abs = error "C has no abs constructor" signum = error "C has no signum constructor" instance Fractional a => Fractional (C a) where (/) = CBin Div fromRational = Num . fromRational m :: C v -> C v m = CUn M mr :: C v mr = CNull MR -- e1, e2, e3 :: Calc e1 :: Num t => t e1 = 1 + 2*3 e2 :: Num v => C v e2 = 6*2 - m (1*3) e3 :: Fractional v => C v e3 = e2/mr -- test1, test2, test3 :: Either Err Value test1, test2, test3 :: (Fractional v, Monad m) => m v test1 = run e1 test2 = run e2 test3 = run e3 prop_sanity :: Fractional v => C v -> Bool prop_sanity e = run (m e / mr) == (Right 1 :: Num v => Either Err v) main :: IO () main = print ([test1, test2, test3, run (1/0)] :: [Either Err Value]) ---------------------------------------------------------------- -- Left-overs {- data Calc = CBin BOp Calc Calc | CUn UOp Calc | CNull NullOp | Num Integer deriving (Eq, Show) -} -- data Button = BDig Char | BBin BOp | BUn UOp | BNull NullOp deriving (Eq, Show)