[Fencommits] fenserve: refactor (changes file format)

[Benja Fallenstein]

Fri Apr 27 21:02:40 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * refactor (changes file format)
diff -rN -u old-fenserve/notetaker/Main.hs new-fenserve/notetaker/Main.hs
--- old-fenserve/notetaker/Main.hs	2007-04-27 21:02:48.000000000 +0300
+++ new-fenserve/notetaker/Main.hs	2007-04-27 21:02:48.000000000 +0300
@@ -1,21 +1,24 @@
 {-# OPTIONS_GHC -fglasgow-exts #-}
 
-import HAppS 
+import HAppS hiding (Body)
 import Control.Monad.State
 import Data.Generics (Typeable)
 import Data.Binary hiding (get,put)
 import Data.Char
-import Data.List (isPrefixOf)
+import Data.List (intersperse, isPrefixOf)
 import Data.Maybe (fromMaybe)
 import Text.Printf
 import System.Time
 
+type Path = [Int]
+data Body = Body String | Add Path String | Edit Path String | Delete Path
+                                      deriving (Eq,Ord,Read,Show,Typeable)
 data Line = Line { lineTime :: EpochTime, lineNick :: String, 
-                   lineBody :: String } deriving (Eq,Ord,Read,Show,Typeable)
+                   lineBody :: Body } deriving (Eq,Ord,Read,Show,Typeable)
                    
 instance Binary Line where
 
-data Note = Note String [Note] deriving (Eq,Ord,Read,Show,Typeable)
+data Note = Note String [Note] deriving (Eq,Ord,Read,Show)
 
 form nick = "<form id='myform' action='/log' method='post'>\
             \    Nick: <input name='nick' type='text' size=8 \
@@ -37,28 +40,25 @@
 renderNotes notes = "<ol>" ++ concatMap renderNote notes ++ "</ol>" where
     renderNote (Note title children) = "<li>" ++ title ++ renderNotes children
     
-execute (Line time nick line0) =
-    if ":del " `isPrefixOf` line0 
-        then delete (map (subtract 1) $ read $ drop 5 line0)
-    else if ":add " `isPrefixOf` line0
-        then let (path, line1) = head $ reads (drop 5 line0)
-              in addToPath (map (subtract 1) path) (dropWhile isSpace line1)
-    else if ":edit " `isPrefixOf` line0
-        then let (path, line1) = head $ reads (drop 6 line0)
-              in edit (map (subtract 1) path) (dropWhile isSpace line1)
-    else id where
-    
-    replace i notes' notes = take i notes ++ notes' ++ drop (i+1) notes
-                                       
-    delete [i]    (Note t cs) = Note t (replace i [] cs)
-    delete (i:is) (Note t cs) = Note t (replace i [delete is $ cs !! i] cs)
-                                       
-    addToPath []     line (Note t cs) = Note t (cs ++ [Note line []])
-    addToPath (i:is) line (Note t cs) =
-        Note t (replace i [addToPath is line $ cs !! i] cs)
-
-    edit []     line (Note _ cs) = Note line cs
-    edit (i:is) line (Note t cs) = Note t (replace i [edit is line $ cs !! i] cs)
+readPath s n f = f (map (subtract 1) path) (dropWhile isSpace line) where
+    ((path, line):_) = reads (drop n s)
+    
+readBody :: String -> Body
+readBody s | ":add "  `isPrefixOf` s = readPath s 5 $ \p l  -> Add p l
+           | ":edit " `isPrefixOf` s = readPath s 6 $ \p l  -> Edit p l
+           | ":del "  `isPrefixOf` s = readPath s 5 $ \p "" -> Delete p
+           | otherwise               = Body s
+    
+execute (Line _ _ (Body _)) = id
+execute (Line _ _ body) =
+    case body of Add p l  -> on p $ \(Note t cs) -> [Note t (cs++[Note l []])]
+                 Edit p l -> on p $ \(Note _ cs) -> [Note l cs]
+                 Delete p -> on p $ \_           -> []
+
+    where on is f note = head $ on' is f note
+          on' []     f note        = f note
+          on' (i:is) f (Note t cs) = 
+              [Note t (take i cs ++ on' is f (cs !! i) ++ drop (i+1) cs)]
 
 getNick m = case lookM m "nick" of Nothing -> "(anon)"; Just "" -> "(anon)"
                                    Just x  -> x
@@ -73,8 +73,19 @@
     lines <- get
     respond $ form nick 
            ++ "Views: <a href='/?nick="++nick++"'>main</a> | <b>log</b><p>"
-           ++ flip concatMap lines (\(Line t n l) ->
-               printf "%s &lt;<b>%s</b>&gt; %s<br>" (renderTime t) n l :: String)
+           ++ flip concatMap lines (\(Line time nick body) -> 
+                  renderTime time ++ " " ++ renderBody nick body ++ "<br>")
+                  
+renderBody :: String -> Body -> String
+renderBody nick (Body s) = printf "&lt;<b>%s</b>&gt; %s" nick s
+renderBody nick body     = printf "<b>%s</b> %s" nick (msg body) where
+    msg :: Body -> String
+    msg (Add [] l) = printf "<i>adds:</i> %s" l
+    msg (Add p l)  = printf "<i>adds to %s:</i> %s" (renderPath p) l
+    msg (Edit p l) = printf "<i>edits %s:</i> %s" (renderPath p) l
+    msg (Delete p) = printf "<i>deletes %s.</i>" (renderPath p)
+    
+    renderPath = concat . intersperse "." . map (show . (+1))
                
 renderTime :: EpochTime -> String
 renderTime t0 = printf "%02u:%02u" (ctHour t) (ctMin t)
@@ -85,7 +96,8 @@
                , h [""]    GET  $ ok $ \() nick -> page nick
                , h ["log"] POST $ ok $ \() (nick,line) -> do 
                      time <- getTime
-                     modify (++[Line time nick line]); renderLog nick
+                     modify (++[Line time nick $ readBody line])
+                     renderLog nick
                , h () POST $ ok $ \() () -> respond "Huh."
                ]