{-# OPTIONS_GHC -fglasgow-exts -cpp #-}
module PIL.Eval () where
untie :: Container -> STM Val
untie = (>> return Void) . cmap (tmap $ maybe undefined (`writeTVar` Untied))
-- | Assign container @x@ to @y@
assign :: Container -- ^ The @$x@ in @$x = $y@
-> Container -- ^ The @$y@ in @$x = $y@
-> STM Val
assign = undefined
-- | Bind container @x@ to @y@
bind :: Container -- ^ The @$x@ in @$x := $y@
-> Container -- ^ The @$y@ in @$x := $y@
-> STM Val
bind = undefined
{-|
To bind a container to another, we first check to see if they are of the
same tieableness. If so, we simply overwrite the target one's Id,
storage and tie-table (if any).
-}
bind (TCon x) (TCon y) = writeSTRef x =<< readSTRef y
bind (NCon x) (NCon y) = writeSTRef x =<< readSTRef y
{-|
To bind an non-tieable container to a tieable one, we implicitly remove
any current ties on the target, although it can be retied later:
-}
bind (TCon x) (NCon y) = do
(id, val) <- readSTRef y
writeSTRef x (id, val, Untied)
{-|
To bind a tieable container to a tied one, we first check if it is
actually tied. If yes, we throw a runtime exception. If not, we
proceed as if both were non-tieable.
-}
bind (NCon x) (TCon y) = do
(id, val, tied) <- readSTRef y
case tied of
Untied -> writeSTRef x (id, val)
_ -> fail "Cannot bind a tied container to a non-tieable one"
-- Haddock can't cope with linear implicit parameters :-(
#ifndef HADDOCK
-- | This should be fine: @untie(%ENV); %foo := %ENV@
testOk :: (%i::Id) => STM ()
testOk = do
x <- hashNew
y <- hashEnv
untie y
bind x y
-- | This should fail: @%foo := %ENV@
testFail :: (%i::Id) => STM ()
testFail = do
x <- hashNew
y <- hashEnv
bind x y
testEquiv :: (%i::Id) => STM (Cell a) -> STM (Cell b) -> STM Bool
testEquiv x y = do
x' <- x
y' <- y
(x' == y')
testBind :: (%i::Id) => STM (Cell a) -> STM (Cell a) -> STM ()
testBind x y = do
x' <- x
y' <- y
bind x' y'
#endif
-- Extremely small language
data Exp
= Bind LV Exp
| Untie LV
deriving (Show, Eq, Ord)
data LV
= HashENV
| HashNew
deriving (Show, Eq, Ord)
type GenContainer a = STM (Cell a)
#ifndef HADDOCK
class Evalable a b | a -> b where
eval :: (%i :: Id) => a -> STM (Cell b)
#endif
instance Evalable Exp Hash where
eval (Untie x) = do
x' <- eval x
untie x'
return x'
instance Evalable LV Hash where
eval HashNew = hashNew
eval HashENV = hashEnv
instance Arbitrary LV where
arbitrary = oneof (map return [HashENV, HashNew])
coarbitrary = assert False undefined
prop_untie :: LV -> Bool
prop_untie x = try_ok (Untie x)
try_ok :: Evalable a b => a -> Bool
try_ok x = runST f
where
f :: STM Bool
f = do
#ifndef HADDOCK
let %i = 0
#endif
eval x
return True
tests :: IO ()
tests = do
#ifndef HADDOCK
let %i = 0
#endif
putStrLn "==> Anything can be untied"
test prop_untie
putStrLn "==> %ENV =:= %ENV;"
print =<< atomically (testEquiv hashEnv hashEnv)
putStrLn "==> %ENV =:= %foo;"
print =<< atomically (testEquiv hashEnv hashNew)
putStrLn "==> %foo =:= %bar;"
print =<< atomically (testEquiv hashNew hashNew)
putStrLn "==> %foo := %bar;"
print =<< atomically (testBind hashNew hashNew)
putStrLn "==> %ENV := %ENV;"
print =<< atomically (testBind hashEnv hashEnv)
putStrLn "==> untie(%ENV); %foo := %ENV;"
print =<< atomically (testBind hashNew $ do { env <- hashEnv; untie env; return env })
putStrLn "==> %foo := %ENV;"
print =<< atomically (testBind hashNew hashEnv)