Dear Haskell
Cafe,
I have a problem I can't get my head around.
The
code below sets the problem out. What I need to be able to do is commented
out.
This code works, the
only problem is that what I need is that an argument will be evaluated before it
is passed,
so ((and fries eats)
eggs) has a single `eggs` (fries1 eggs2 and3 eats4 egg2) not (fries1 eggs2
and3 eats4 eggs5).
The code that
doesn't work is commented out at the bottom. I'm not sure the
behaviour of ghc is correct, because
when
it typechecks it tries to unify `b = t t1`
but `b` could actually be `t t1 -> t t1`.
I want to be able to
specify that when the first argument of `b` is of type `m a` that fork should
run it and _then_
fork the
argument to the first two arguments of 'fork'. The instance for (a -> b) covers the rest of
the possibilities.
just type "run test[1-4]" to see
results.
\begin{code}
{-# OPTIONS_GHC -fglasgow-exts
-fno-monomorphism-restriction #-}
module Fork where
{-----------------------------------------------------------------------------}
import Prelude hiding (and)
import Control.Monad.State
{-----------------------------------------------------------------------------}
data NRef = NS0
String
| NS1 String
NRef
| NS2 String NRef
NRef
deriving(Show)
{-----------------------------------------------------------------------------}
data UniqueS = US { nums :: [String]
}
deriving(Show)
type USM a = StateT UniqueS IO a
newUniqueS :: UniqueS
newUniqueS = US { nums = [
show x | x <- [1..] ] }
freshInstance :: String -> USM
String
freshInstance x =
do
(f:fs) <- gets
nums
put $ US { nums = fs
}
return $ x ++ f
{-----------------------------------------------------------------------------}
single x = do
x' <-
freshInstance x
return $ NS0 x'
unary x n = do
x' <-
freshInstance x
n' <- n
return $
NS1 x' n'
binary x n1 n2 = do
x' <-
freshInstance x
n1' <- n1
n2'
<- n2
return $ NS2 x' n1' n2'
{-----------------------------------------------------------------------------}
foxy = single "foxy"
eggs = single
"eggs"
golden = unary "golden"
white = unary "white"
fries = binary
"fries"
eats = binary "eats"
{-----------------------------------------------------------------------------}
class Forkable a where
fork
:: String -> a -> a -> a
instance (Forkable a, Forkable b) => Forkable (a
-> b) where
fork n a1 a2 a = fork n (a1 a) (a2
a)
{-
instance (Monad m, Forkable (m a),
Forkable b) => Forkable (m a -> b) where
fork n a1
a2 a =
do
a' <-
a
fork n (a1 $ return a')
(a2 $ return
a')
-}
{-----------------------------------------------------------------------------}
instance Forkable (USM NRef)
where
fork n a1 a2 =
do
a1' <-
a1
a2' <-
a2
return $ NS2 n a1' a2'
{-----------------------------------------------------------------------------}
and = fork "and"
test1 = (and foxy eggs)
test2 = (and golden
white) eggs
test3 = (and fries eats) foxy eggs
test4 = (eats foxy (and
(golden eggs) (white eggs)))
run x = runStateT x newUniqueS >>=
(putStrLn . show . fst)
\end{code