another alternative monad

1 files changed, 108 insertions, 1 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index 71d4bd1..c05e9e7 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -382,6 +382,8 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
     mergeSubSig n sig Nothing = error $
         "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
 
+ 
+{-
 data Kiki a =
     SinglePass (KeyRingData -> KeyRingAction a)
     | forall b. MultiPass (KeyRingData -> KeyRingAction b)
@@ -403,6 +405,7 @@ instance Monad Kiki where
     return x = SinglePass (const $ KeyRingAction x)
     
     k >>= f  = eval' $ fmapWithRT (\rt x -> eval rt (f x)) k
+                where (.:) = (.) . (.)
 
 eval :: KeyRingRuntime -> Kiki a -> KeyRingData -> a
 eval rt (SinglePass f) kd =
@@ -418,7 +421,11 @@ eval' k@(SinglePass pass) = SinglePass pass'
                 RunTimeAction g -> RunTimeAction (\rt -> g rt kd)
 eval' k@(MultiPass p kk) = MultiPass p kk'
  where
-    kk' = eval' $ fmap flip kk
+    kk' = fmap flip kk
+
+-}
+
+
 
 {-
 fmapWithRT g (SinglePass d@(KeyRingData { kAction = KeyRingAction v}))
@@ -431,6 +438,106 @@ fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk)
 -}
 
 
+data Kiki a =
+    SinglePass { passInfo :: KeyRingData
+               , rtAction :: KeyRingAction a }
+    | forall b.
+       MultiPass { passInfo :: KeyRingData
+                 , passAction :: KeyRingAction b
+                 , nextPass :: Kiki (b -> a)
+                 }
+
+
+
+evalAction :: KeyRingRuntime -> KeyRingAction a -> a
+evalAction rt (KeyRingAction v) = v
+evalAction rt (RunTimeAction g) = g rt
+
+instance Monad KeyRingAction where
+    return x = KeyRingAction x
+    m >>= g  = case m of
+        KeyRingAction v -> g v
+        RunTimeAction f -> RunTimeAction $ \rt -> evalAction rt (g $ f rt)
+
+instance Functor KeyRingAction where
+    fmap g (KeyRingAction v) = KeyRingAction $ g v
+    fmap g (RunTimeAction f) = RunTimeAction $ \rt -> g (f rt)
+
+{-
+argOut :: (KeyRingAction (a -> b)) -> a -> KeyRingAction b
+argOut = todo
+argIn :: (a -> KeyRingAction b) -> KeyRingAction (a->b)
+-}
+
+{-
+fmapWithRT :: (a -> KeyRingAction b) -> Kiki a -> Kiki b
+fmapWithRT g k@(SinglePass {}) = k { rtAction = action }
+ where
+    action = rtAction k >>= g
+fmapWithRT g (MultiPass p atn next) = MultiPass p atn next'
+ where
+    next' = fmapWithRT g' next {- next :: Kiki (x -> a) -}
+    -- g' :: ( (x->a) -> KeyRingAction b)
+    g' h = RunTimeAction $
+            \rt x -> case g (h x) of
+                        KeyRingAction v -> v
+                        RunTimeAction f -> f rt
+-}
+
+fmapWithRT :: KeyRingAction (a -> b) -> Kiki a -> Kiki b
+fmapWithRT g (SinglePass pass atn) = SinglePass pass atn'
+ where
+    atn' = g >>= flip fmap atn
+fmapWithRT g (MultiPass p atn next) = MultiPass p atn next'
+ where
+    next' = fmapWithRT g' next
+    g' = fmap (\gf h -> gf . h) g
+
+instance Functor Kiki where
+    fmap f k = fmapWithRT (return f) k
+
+instance Monad Kiki where
+    return x = SinglePass todo (return x)
+    k >>= f  = kjoin $ fmap f k
+
+kikiAction :: Kiki a -> KeyRingAction a
+kikiAction (SinglePass _ atn) = atn
+kikiAction (MultiPass _ atn next) = do
+        x <- atn
+        g <- kikiAction next
+        return $ g x
+
+kjoin :: Kiki (Kiki a) -> Kiki a
+kjoin k = fmapWithRT eval' k
+ where
+    eval' :: KeyRingAction (Kiki a -> a)
+    eval' = RunTimeAction (\rt -> evalAction rt . kikiAction )
+
+    {-
+    kjoin :: Kiki (Kiki a) -> Kiki a
+    kjoin k = kjoin' (fmap kikiAction k)
+     where
+        ev rt (KeyRingAction v) = v
+        ev rt (RunTimeAction g) = g rt
+
+        kjoin' :: Kiki (KeyRingAction a) -> Kiki a
+        kjoin' (SinglePass pass atn) = SinglePass pass $ join atn
+        kjoin' (MultiPass pass atn next) = MultiPass pass atn next'
+            where
+                next' = todo
+    -}
+
+
+{-
+instance Functor Kiki where
+    fmap f (SinglePass pass atn)
+        = SinglePass pass (fmap f atn)
+    fmap f (MultiPass pass atn next)
+        = MultiPass pass atn (next >>= g)
+     where
+        g = todo
+-}
+
 {-
 data Kiki a = SinglePass (KeyRingData a)
               | forall b. MultiPass (KeyRingData b) (Kiki (b -> a))