experimental monad instance

1 files changed, 133 insertions, 7 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index b223ee7..6d1ff3b 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ExistentialQuantification #-}
 module KeyRing where
 
 import System.Environment
@@ -33,7 +34,12 @@ home = HomeDir
     , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
     }
 
-data InputFile = HomeSec | HomePub | ArgFile FilePath
+data InputFile = HomeSec | HomePub | ArgFile FilePath | FileDesc Int
+
+data FileType = KeyRingFile | PEMFile | WalletFile
+
+data RefType = ConstRef | MutableRef
+
 
 data KeyRingRuntime = KeyRingRuntime
                         { rtPubring :: FilePath
@@ -43,14 +49,17 @@ data KeyRingRuntime = KeyRingRuntime
                         , rtGrip :: Maybe String
                         }
 
+data KeyRingAction a = KeyRingAction a | RunTimeAction (KeyRingRuntime -> a)
+
 data KeyRingData a = KeyRingData
-    { filesToLock :: [InputFile]
+    { kFiles :: Map.Map InputFile (RefType,FileType)
     , homeSpec :: Maybe String
-    , kaction :: KeyRingRuntime -> IO a
-    , keyringFiles :: [FilePath]
-    , walletFiles :: [FilePath]
+    , kAction :: KeyRingAction a
     }
 
+kret :: a -> KeyRingData a
+kret x = KeyRingData Map.empty Nothing (KeyRingAction x)
+
 todo = error "unimplemented"
 
 data KikiCondition a = KikiSuccess a | FailedToLock [FilePath]
@@ -77,6 +86,7 @@ data KikiResult a = KikiResult
     , kikiReport :: [ (FilePath, KikiReportAction) ]
     }
 
+{-
 empty = KeyRingData { filesToLock = []
                     , homeSpec = Nothing
                     , kaction = \KeyRingRuntime {} -> return ()
@@ -116,6 +126,7 @@ runKeyRing keyring = do
     forM_ lked $ \(Just lk, fname) -> do dotlock_release lk
                                          dotlock_destroy lk
     return KikiResult { kikiCondition = ret, kikiReport = [] }
+-}
 
 parseOptionFile fname = do
     xs <- fmap lines (readFile fname)
@@ -372,10 +383,125 @@ 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 = Kiki
+data Kiki a = SinglePass (KeyRingData a)
+              | forall b. MultiPass (KeyRingData b) (Kiki (b -> a))
+
+instance Functor Kiki where
+    fmap f (SinglePass d) = SinglePass $ case kAction d of
+                                  KeyRingAction v -> d { kAction = KeyRingAction (f v) }
+                                  RunTimeAction g -> d { kAction = RunTimeAction (f . g) }
+    fmap f (MultiPass p k)= MultiPass p (fmap (f .) k)
+
+eval :: KeyRingRuntime -> Kiki a -> a
+eval rt (SinglePass (KeyRingData { kAction = KeyRingAction v})) = v
+eval rt (SinglePass (KeyRingData { kAction = RunTimeAction f})) = f rt
+eval rt (MultiPass p kk) = eval rt kk $ eval rt (SinglePass p)
+
+fmapWithRT :: (KeyRingRuntime -> a -> b) -> Kiki a -> Kiki b
+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
+
+kjoin :: Kiki (Kiki a) -> Kiki a
+kjoin k = fmapWithRT eval k
+
+passCount :: Kiki a -> Int
+passCount (MultiPass _ k) = 1 + passCount k
+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 = todo
+goHome p = SinglePass $ (kret ()) { homeSpec = p }
 
 syncRing :: InputFile -> Kiki ()
 syncRing = todo