Ops.hs

{-# OPTIONS_GHC -fglasgow-exts #-}
{-# LANGUAGE GADTs, ScopedTypeVariables, EmptyDataDecls, FlexibleInstances, ImpredicativeTypes, NoMonoPatBinds #-}
-- XXX Despite what I think should be enough LANGUAGE options I still need -fglasgow-exts.
module Language.CMonad.Ops(module Language.CMonad.Ops) where
import qualified Prelude as P
import System.IO
import Language.CMonad.CPrelude
import Language.CMonad.MonadRef(MonadRef)
import Language.CMonad.Prim

{-# INLINE liftE0 #-}
liftE0 :: (Monad m) => a -> E m a
liftE0 op = embed $ return op

{-# INLINE liftE1 #-}
liftE1 :: (Monad m) => (a -> b) -> E' v m a -> E m b
liftE1 op x = embed $ do
    x' <- runE x
    return (op x')

{-# INLINE liftE2 #-}
liftE2 :: (Monad m) => (a -> b -> c) -> E' va m a -> E' vb m b -> E m c
liftE2 op x y = embed $ do
    x' <- runE x
    y' <- runE y
    return (x' `op` y')


{-# INLINE pure0 #-}
pure0 :: (Monad m) => a -> E m a
pure0 = return

-----------------------------

instance P.Eq (E m a)
instance Show (E m a)

instance (Monad m, Num a) => Num (E m a) where
    (+) = liftE2 (+)
    (-) = liftE2 (-)
    (*) = liftE2 (*)
    negate = liftE1 negate
    abs = liftE1 abs
    signum = liftE1 signum
    fromInteger = liftE0 . fromInteger

instance (Monad m, Fractional a) => Fractional (E m a) where
    (/) = liftE2 (/)
    recip = liftE1 recip
    fromRational = liftE0 . fromRational

instance (Monad m) => Boolean (E m Bool) where
    false = pure0 False
    true = pure0 True
    not = liftE1 not
    x && y = embed $ do
        x' <- runE x
        if x' then runE y else return False
    x || y = embed $ do
        x' <- runE x
        if x' then return True else runE y

instance (Monad m, Eq a Bool) => Eq (E m a) (E m Bool) where
    (==) = liftE2 (==)
    (/=) = liftE2 (/=)

instance (Monad m, Ord a Bool) => Ord (E m a) (E m Bool) where
    (<) = liftE2 (<)
    (<=) = liftE2 (<=)
    (>) = liftE2 (>)
    (>=) = liftE2 (>=)

-----------------------------

infix 0 *=, -=, +=
(*=), (-=), (+=) :: (Monad m, Num (E m a)) => (forall v . E' v m a) -> E m a -> E m a
{-# INLINE (*=) #-}
v *= x = v =: v * x
{-# INLINE (+=) #-}
v += x = v =: v + x
{-# INLINE (-=) #-}
v -= x = v =: v - x

infix 0 =:=
{-# INLINE (=:=) #-}
(=:=) :: (MonadRef m r) => (forall v . E' v m a) -> (forall v . E' v m a) -> E m ()
x =:= y = do
    t <- auto x
    x =: y
    y =: t
    return ()

autoU :: (MonadRef m r) => E m (forall v . E' v m a)
autoU = auto undefined

-----------------------------

while :: (Monad m) => E m Bool -> E m a -> E m ()
while c a = if1 c $ do a; while c a

until :: (Monad m) => E m Bool -> E m a -> E m ()
until c a = do
    a
    if1 (not c) $ until c a

repeatUntil :: (Monad m) => E m a -> E m Bool -> E m a -> E m ()
repeatUntil a1 c a2 = do
    a1
    if1 (not c) $ do a2; repeatUntil a1 c a2

{-# INLINE if1 #-}
if1 :: (Monad m) => E m Bool -> E m a -> E m ()
if1 c a = do
    c' <- c
    if c' then do a; skip else skip

{-# INLINE if2 #-}
if2 :: (Monad m) => E m Bool -> E m a -> E m b -> E m ()
if2 c a b = do
    c' <- c
    if c' then do a; skip else do b; skip

{-# INLINE for #-}
for :: (Monad m) => (E m a, E m Bool, E m b) -> E m c -> E m ()
for (init, cmp, inc) body = do
    init
    while cmp $ do body; inc

{-# INLINE skip #-}
skip :: (Monad m) => m ()
skip = return ()

{-# INLINE retrn #-}
retrn :: E m a -> E m a
retrn x = x

-----------------------------

type EIO a = E IO a

getchar :: () -> EIO Int
getchar () = embed $ do
    eof <- hIsEOF stdin
    if eof then
        return (-1)
     else
        fmap fromEnum $ hGetChar stdin
 
putchar :: EIO Int -> EIO Int
putchar c = embed $ do
    c' <- runE c
    hPutChar stdout (toEnum c')
    return 0