alternative experimental monad instance

1 files changed, 54 insertions, 81 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index 6d1ff3b..71d4bd1 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -51,14 +51,13 @@ data KeyRingRuntime = KeyRingRuntime
 
 data KeyRingAction a = KeyRingAction a | RunTimeAction (KeyRingRuntime -> a)
 
-data KeyRingData a = KeyRingData
+data KeyRingData = KeyRingData
     { kFiles :: Map.Map InputFile (RefType,FileType)
     , homeSpec :: Maybe String
-    , kAction :: KeyRingAction a
     }
 
-kret :: a -> KeyRingData a
-kret x = KeyRingData Map.empty Nothing (KeyRingAction x)
+-- kret :: a -> KeyRingData a
+-- kret x = KeyRingData Map.empty Nothing (KeyRingAction x)
 
 todo = error "unimplemented"
 
@@ -383,6 +382,56 @@ 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)
+                          (Kiki (b -> a))
+
+fmapWithRT :: (KeyRingRuntime -> a -> b) -> Kiki a -> Kiki b
+fmapWithRT g (SinglePass pass) = SinglePass pass'
+ where
+    pass' kd = case pass kd of
+                KeyRingAction v -> RunTimeAction (\rt -> g rt v)
+                RunTimeAction f -> RunTimeAction (\rt -> g rt (f rt))
+fmapWithRT g (MultiPass pass0 k) = MultiPass pass0 k'
+ where
+    k' = fmapWithRT (\rt f -> g rt . f) k
+
+instance Functor Kiki where fmap f k = fmapWithRT (const f) k
+
+instance Monad Kiki where
+    return x = SinglePass (const $ KeyRingAction x)
+    
+    k >>= f  = eval' $ fmapWithRT (\rt x -> eval rt (f x)) k
+
+eval :: KeyRingRuntime -> Kiki a -> KeyRingData -> a
+eval rt (SinglePass f) kd =
+    case f kd of KeyRingAction v -> v
+                 RunTimeAction g -> g rt                       
+eval rt (MultiPass p kk) kd = eval rt kk kd $ eval rt (SinglePass p) kd
+
+eval' :: Kiki (KeyRingData -> a) -> Kiki a
+eval' k@(SinglePass pass) = SinglePass pass'
+ where
+    pass' kd = case pass kd of
+                KeyRingAction f -> KeyRingAction (f kd)
+                RunTimeAction g -> RunTimeAction (\rt -> g rt kd)
+eval' k@(MultiPass p kk) = MultiPass p kk'
+ where
+    kk' = eval' $ fmap flip kk
+
+{-
+fmapWithRT g (SinglePass d@(KeyRingData { kAction = KeyRingAction v}))
+    = SinglePass $ d { kAction = RunTimeAction (\rt -> g rt v) }
+fmapWithRT g (SinglePass d@(KeyRingData { kAction = RunTimeAction f}))
+    = SinglePass $ d { kAction = RunTimeAction f' }
+    where f' rt = g rt (f rt)
+fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk)
+    where g' rt h = g rt . h
+-}
+
+
+{-
 data Kiki a = SinglePass (KeyRingData a)
               | forall b. MultiPass (KeyRingData b) (Kiki (b -> a))
 
@@ -416,92 +465,16 @@ passCount (SinglePass {}) = 1
 instance Monad Kiki where
     return x = SinglePass (kret x)
     k >>= f  = kjoin (fmap f k)
-
-{-
-kjoin :: Kiki (Kiki a) -> Kiki a
-kjoin (SinglePass d) =
-  case kAction d of
-    KeyRingAction v -> v
-    RunTimeAction g -> SinglePass (d { kAction = RunTimeAction g' })
-                       where g' rt = eval rt (g rt)
-       
-kjoin (MultiPass p k)= MultiPass p (fmapWithRT f k)
- where
-    {-
-    k' = case k of
-           SinglePass (d { kAction 
-    k :: Kiki (b -> Kiki a)
-    k' :: Kiki (b -> a)
-    -}
-    {-
-    f :: (b->Kiki a) -> Kiki (b -> a)
-    f g = SinglePass (p { kAction = RunTimeAction g' })
-        where g' rt = \b -> eval rt (g b)
-    -}
-    f :: KeyRingRuntime -> (b->Kiki a) -> (b -> a)
-    f rt g b = eval rt (g b)
 -}
 
 
-ktrav :: Kiki (x -> y) -> x -> Kiki y
-ktrav (SinglePass kk) x = SinglePass $ case kAction kk of KeyRingAction f -> kk { kAction = KeyRingAction (f x) }
-
-{-
-instance Monad Kiki where
-    return x = SinglePass (kret x)
-
-    kiki >>= f
-        = join (fmap f kiki)
-      where
-        join (SinglePass kd) =
-            case kAction kd of
-                KeyRingAction kiki -> kiki
-                RunTimeAction g ->
-                    let go rt = case g rt of
-                                  SinglePass q -> todo
-                    in SinglePass (kd { kAction = RunTimeAction go })
-        join (MultiPass x y) = MultiPass x (join y)
--}
-        
-
-{-
-data Kiki a = SinglePass (KeyRingData a)
-              | MultiPass (KeyRingData (Kiki a))
-lastPass :: Kiki a -> KeyRingRuntime -> KeyRingData a
-lastPass (SinglePass d) rt = d
-lastPass (MultiPass k) rt = case kAction k of
-                                KeyRingAction v -> lastPass v rt
-                                RunTimeAction f -> lastPass (f rt) rt
-
-instance Monad Kiki where
-    return x = SinglePass (kret x)
-    SinglePass (kd@(KeyRingData { kAction = KeyRingAction x })) >>= f
-        = f x
-    SinglePass (kd@(KeyRingData { kAction = RunTimeAction g })) >>= f
-        = SinglePass (kd { kAction = RunTimeAction g' })
-      where
-        g' rt = case f (g rt) of
-                  SinglePass d ->
-                    case kAction d of
-                        KeyRingAction y -> y
-                        RunTimeAction h -> h rt
-                  {-
-                  MultiPass d ->
-                    case kAction d of
-                        KeyRingAction k' -> k' >>= f
-                  -}
-
-runKiki :: KeyRingRuntime -> Kiki a -> a
-runKiki = todo
--}
-
 -- Kiki a -> a -> Kiki b
 
 atRuntime :: (KeyRingRuntime -> IO (a,KeyRingRuntime)) -> Kiki a
 atRuntime = todo
 
 goHome :: Maybe FilePath -> Kiki ()
-goHome p = SinglePass $ (kret ()) { homeSpec = p }
+goHome p = todo -- SinglePass $ (kret ()) { homeSpec = p }
 
 syncRing :: InputFile -> Kiki ()
 syncRing = todo