module NewCache(allcacheF) where
import Command
--import Event
import FRequest
--import Fudget
--import Loopthrough
import Spops
import LoopLow
import Cont
import IsRequest
--import DialogueIO hiding (IOError)
import qualified Data.Map as OM

--import Maptrace(ctrace) -- debug
--import NonStdTrace(trace)

-- A new implementation of the X resource cache.
-- TODO: reference counters and the ability to free unused resources.

allcacheable :: XRequest -> Bool
allcacheable XRequest
xreq =
  case XRequest
xreq of
    LoadFont FontName
fn -> Bool
True
    QueryFont FontId
f -> Bool
True
    LoadQueryFont FontName
s -> Bool
True
    ListFonts FontName
pat Int
max -> Bool
True
    ListFontsWithInfo FontName
pat Int
max -> Bool
True
    CreateGC Drawable
d GCId
t GCAttributeList
as -> Bool
True
    -- FreeGC gcid 
    AllocNamedColor ColormapId
cm FontName
cn -> Bool
True
    AllocColor ColormapId
cm RGB
rgb -> Bool
True
    -- FreeColors cm [pixel] (Pixel 0)
    CreateFontCursor Int
shape -> Bool
True
    ReadBitmapFile FontName
name -> Bool
True
    CreateBitmapFromData BitmapData
bdata -> Bool
True -- hmm, big request, small result...
    XRequest
_ -> Bool
False

allcacheF :: F i o -> F i o
allcacheF = (XRequest -> Bool) -> F i o -> F i o
forall i o. (XRequest -> Bool) -> F i o -> F i o
cacheF XRequest -> Bool
allcacheable

cacheF :: (XRequest -> Bool) -> F i o -> F i o
cacheF XRequest -> Bool
cacheable F i o
fud = SP (Either TCommand TEvent) (Either TCommand TEvent)
-> F i o -> F i o
forall i o.
SP (Either TCommand TEvent) (Either TCommand TEvent)
-> F i o -> F i o
loopThroughLowF (Map XRequest FResponse
-> SP (Either TCommand TEvent) (Either TCommand TEvent)
forall a.
Map XRequest FResponse
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
cc Map XRequest FResponse
forall k a. Map k a
OM.empty) F i o
fud where
  cc :: Map XRequest FResponse
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
cc Map XRequest FResponse
table = SP
  (Either (a, FRequest) (a, FResponse))
  (Either (a, FRequest) (a, FResponse))
same where
     same :: SP
  (Either (a, FRequest) (a, FResponse))
  (Either (a, FRequest) (a, FResponse))
same = Cont
  (SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse)))
  (Either (a, FRequest) (a, FResponse))
forall a b. Cont (SP a b) a
getSP Either (a, FRequest) (a, FResponse)
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
cachehandle
     cachehandle :: Either (a, FRequest) (a, FResponse)
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
cachehandle Either (a, FRequest) (a, FResponse)
msg = case Either (a, FRequest) (a, FResponse)
msg of 
       Left tc :: (a, FRequest)
tc@(a
tag,FRequest
c) ->
	   case FRequest
c of
	     XReq XRequest
xreq ->
	       if XRequest -> Bool
cacheable XRequest
xreq
	       then case XRequest -> Map XRequest FResponse -> Maybe FResponse
forall k a. Ord k => k -> Map k a -> Maybe a
OM.lookup XRequest
xreq Map XRequest FResponse
table of
		      Just FResponse
r -> Either (a, FRequest) (a, FResponse)
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
forall b a. b -> SP a b -> SP a b
putSP ((a, FResponse) -> Either (a, FRequest) (a, FResponse)
forall a b. b -> Either a b
Right (a
tag,FResponse
r)) (SP
   (Either (a, FRequest) (a, FResponse))
   (Either (a, FRequest) (a, FResponse))
 -> SP
      (Either (a, FRequest) (a, FResponse))
      (Either (a, FRequest) (a, FResponse)))
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
forall a b. (a -> b) -> a -> b
$
				Map XRequest FResponse
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
cc Map XRequest FResponse
table
		      Maybe FResponse
Nothing -> (FResponse
 -> SP
      (Either (a, FRequest) (a, FResponse))
      (Either (a, FRequest) (a, FResponse)))
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
forall a a.
(FResponse
 -> SP
      (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse)))
-> SP
     (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse))
waitresp ((FResponse
  -> SP
       (Either (a, FRequest) (a, FResponse))
       (Either (a, FRequest) (a, FResponse)))
 -> SP
      (Either (a, FRequest) (a, FResponse))
      (Either (a, FRequest) (a, FResponse)))
-> (FResponse
    -> SP
         (Either (a, FRequest) (a, FResponse))
         (Either (a, FRequest) (a, FResponse)))
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
forall a b. (a -> b) -> a -> b
$ \FResponse
r ->
				 --ctrace "trcache" ("alloc",c,d,r) $
				 Map XRequest FResponse
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
cc (XRequest
-> FResponse -> Map XRequest FResponse -> Map XRequest FResponse
forall k a. Ord k => k -> a -> Map k a -> Map k a
OM.insert XRequest
xreq FResponse
r Map XRequest FResponse
table)
	       else (FResponse
 -> SP
      (Either (a, FRequest) (a, FResponse))
      (Either (a, FRequest) (a, FResponse)))
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
forall a a.
(FResponse
 -> SP
      (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse)))
-> SP
     (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse))
waitresp ((FResponse
  -> SP
       (Either (a, FRequest) (a, FResponse))
       (Either (a, FRequest) (a, FResponse)))
 -> SP
      (Either (a, FRequest) (a, FResponse))
      (Either (a, FRequest) (a, FResponse)))
-> (FResponse
    -> SP
         (Either (a, FRequest) (a, FResponse))
         (Either (a, FRequest) (a, FResponse)))
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
forall a b. (a -> b) -> a -> b
$ \FResponse
r -> SP
  (Either (a, FRequest) (a, FResponse))
  (Either (a, FRequest) (a, FResponse))
same
	     FRequest
_ -> if FRequest -> Bool
isRequest FRequest
c
		  then (FResponse
 -> SP
      (Either (a, FRequest) (a, FResponse))
      (Either (a, FRequest) (a, FResponse)))
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
forall a a.
(FResponse
 -> SP
      (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse)))
-> SP
     (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse))
waitresp ((FResponse
  -> SP
       (Either (a, FRequest) (a, FResponse))
       (Either (a, FRequest) (a, FResponse)))
 -> SP
      (Either (a, FRequest) (a, FResponse))
      (Either (a, FRequest) (a, FResponse)))
-> (FResponse
    -> SP
         (Either (a, FRequest) (a, FResponse))
         (Either (a, FRequest) (a, FResponse)))
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
forall a b. (a -> b) -> a -> b
$ \FResponse
r -> SP
  (Either (a, FRequest) (a, FResponse))
  (Either (a, FRequest) (a, FResponse))
same
		  else SP
  (Either (a, FRequest) (a, FResponse))
  (Either (a, FRequest) (a, FResponse))
psame
         where waitresp :: (FResponse
 -> SP
      (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse)))
-> SP
     (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse))
waitresp FResponse
-> SP
     (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse))
c = Either (a, FRequest) (a, FResponse)
-> (Either a (a, FResponse) -> Maybe (a, FResponse))
-> Cont
     (SP
        (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse)))
     (a, FResponse)
forall a b c. a -> (b -> Maybe c) -> Cont (SP b a) c
cmdContSP ((a, FRequest) -> Either (a, FRequest) (a, FResponse)
forall a b. a -> Either a b
Left (a, FRequest)
tc)
		 (\Either a (a, FResponse)
msg->case Either a (a, FResponse)
msg of Right te :: (a, FResponse)
te@(a
_,FResponse
e) | FResponse -> Bool
isResponse FResponse
e -> (a, FResponse) -> Maybe (a, FResponse)
forall a. a -> Maybe a
Just (a, FResponse)
te
				    Either a (a, FResponse)
_ -> Maybe (a, FResponse)
forall a. Maybe a
Nothing) Cont
  (SP
     (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse)))
  (a, FResponse)
-> Cont
     (SP
        (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse)))
     (a, FResponse)
forall a b. (a -> b) -> a -> b
$ \tr :: (a, FResponse)
tr@(a
_,FResponse
r) ->
		 Either (a, FRequest) (a, FResponse)
-> SP
     (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse))
-> SP
     (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse))
forall b a. b -> SP a b -> SP a b
putSP ((a, FResponse) -> Either (a, FRequest) (a, FResponse)
forall a b. b -> Either a b
Right (a, FResponse)
tr) (SP (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse))
 -> SP
      (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse)))
-> SP
     (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse))
-> SP
     (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse))
forall a b. (a -> b) -> a -> b
$ FResponse
-> SP
     (Either a (a, FResponse)) (Either (a, FRequest) (a, FResponse))
c FResponse
r
       Right (a, FResponse)
_ -> SP
  (Either (a, FRequest) (a, FResponse))
  (Either (a, FRequest) (a, FResponse))
psame
      where
       pass :: SP a (Either (a, FRequest) (a, FResponse))
-> SP a (Either (a, FRequest) (a, FResponse))
pass = Either (a, FRequest) (a, FResponse)
-> SP a (Either (a, FRequest) (a, FResponse))
-> SP a (Either (a, FRequest) (a, FResponse))
forall b a. b -> SP a b -> SP a b
putSP Either (a, FRequest) (a, FResponse)
msg
       psame :: SP
  (Either (a, FRequest) (a, FResponse))
  (Either (a, FRequest) (a, FResponse))
psame = SP
  (Either (a, FRequest) (a, FResponse))
  (Either (a, FRequest) (a, FResponse))
-> SP
     (Either (a, FRequest) (a, FResponse))
     (Either (a, FRequest) (a, FResponse))
forall a.
SP a (Either (a, FRequest) (a, FResponse))
-> SP a (Either (a, FRequest) (a, FResponse))
pass SP
  (Either (a, FRequest) (a, FResponse))
  (Either (a, FRequest) (a, FResponse))
same