Unsafe.hs.include

[ForFunction "prim_unsafePerformIO"
,ForFunction "spawnConstraint"
,ForFunction "prim_isVar"
,ForFunction "prim_identicalVar"
,ForFunction "prim_showAnyTerm"
,ForFunction "prim_showAnyQTerm"
,ForFunction "prim_readsAnyUnqualifiedTerm"
,ForFunction "prim_readsAnyQTerm"
,ForFunction "showAnyExpression"
,ForFunction "showAnyQExpression"
]

import System.IO.Unsafe 
import Data.IORef

prim_isVar :: Curry a => a -> Result C_Bool
prim_isVar x _ = case consKind x of
  Branching -> toCurry (isGenerator (orRef x))
  _         -> C_False

prim_unsafePerformIO :: Curry a => C_IO a -> Result a
prim_unsafePerformIO (C_IO action) st = unsafe (unsafePerformIO (action st)) st
 

unsafe :: Curry a => IOVal a -> Result a
unsafe (IOVal v)        _  = v
unsafe (IOValFail e)    _  = Curry.RunTimeSystem.failed e
unsafe (IOValOr r bs)   st = mapOr (\ x -> unsafe (unsafePerformIO x)) r bs st
{-
-- the main point about unsafe:  the value of suspensions has to be stored.
unsafe (IOValSusp _ susp) = let sRef = nextSuspRef () in
  suspend False  (saveSuspValue sRef (const (tra sRef "cont" unsafe)) 
                                (\st -> tra sRef "" (unsafePerformIO (susp (Just st)))))

-- Sometimes we have to make sure that suspensions are not evaluated twice.
-- Most notably this is true for suspended unsafely performed io actions .
-- This function saves its result in the store and retrieves it whenever 
-- called. Only when there has been no value stored yet, the given suspension 
-- is called with the store.
-- Saving suspensions values this way is a bit complicated.
-- First, look if suspension already lifted from somewhere else. 
--   if so, the result has already been stored
--   if not, test if suspension can be lifted with given store
--             if so, call cont and save result in store (shared!)
--             if not, test if suspension did at least something (test sref)
--                        if so, recursive call with new suspension
--                        if not, suspend with given sRef "done Nothing"
saveSuspValue :: (Curry a,Curry b) => 
             FreeVarRef -> (State -> a -> b) -> (Store -> a) -> Store -> b
saveSuspValue sRef cont susp store = 
  trace "saveSuspValue " $
  case fromStore store sRef of
     Nothing -> trace "saveSusp: Nothing" $ let x = susp store in
       case consKind x of
        Suspended -> if suspRef x then saveSuspValue sRef cont (suspCont x) store 
                                  else suspend False (saveSuspValue sRef cont (suspCont x))
        _ -> tr "saveSusp: not suspended" $ let res = cont (Just store) x in
          branching (nextOrRef ())
                [(\st -> Modified (addToStore st sRef res),trace "saveSusp: res" res)]
     Just v -> trace "saveSusp: Just" trV v v
  where
    tr = tra sRef
    trV x =  case consKind x of
       Branching -> case branches x of
                     [(_,b)] -> trV b
                     bs -> trace $ "Branch length " ++ (show $ length bs)
       ck -> tr (show ck)

-}

prim_identicalVar :: Curry a => a  -> a -> Result C_Bool
prim_identicalVar x y _ = case (consKind x,consKind y) of
  (Branching,Branching) -> let rx = orRef x
                               ry = orRef y in
                           if isGenerator rx && isGenerator ry
                           then toCurry (deref rx Prelude.== deref ry)
                           else C_False
  _                     -> C_False


prim_showAnyTerm t _ = toCurry (show t)

prim_showAnyQTerm :: Curry a => a -> Result C_String
prim_showAnyQTerm x _ = toCurry (showQ 0 x "")

prim_readsAnyUnqualifiedTerm = error "ExternalFunctionsUnsafe.prim_readsAnyUnqualifiedTerm"

prim_readsAnyQTerm = error "ExternalFunctionsUnsafe.prim_readsAnyQTerm"

showAnyExpression = error "ExternalFunctionsUnsafe.prim_showAnyExpression"


showAnyQExpression = error "ExternalFunctionsUnsafe.prim_showAnyQExpression"

--spawnConstraint :: Curry a => C_Success -> a -> a
spawnConstraint _ c x = undefined 

try :: Curry a => a -> Result (C_Either a (T2 C_OrRef (List a)))
try x _ = case consKind x of
          Val       -> C_Left x
          Branching -> C_Right (T2 (C_OrRef (orRef x)) 
                                   (fromHaskellList (branches x)))
          c -> error ("try: consKind is "++show c)

orsWithOrRef :: Curry a => C_OrRef -> List a -> Result a
orsWithOrRef (C_OrRef r) xs _ = branching r (toHaskellList xs)

generateChoice :: Curry a => List a -> Result a
generateChoice xs _ = branching (mkRef 0 0 (nextRef 0)) (toHaskellList xs)


nrOfChoices :: Result (C_IO C_Int)
nrOfChoices st = 
  C_IO (\ st' -> Prelude.return (IOVal (toCurry (max (size' st) (size' st')))))
  where
    size' = storeSize