[Fencommits] fenserve: put in the missing things so that the code can read back the URI it links to :)

[Benja Fallenstein]

Wed Jun 20 14:55:29 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * put in the missing things so that the code can read back the URI it links to :)
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs	2007-06-20 14:56:10.000000000 +0300
+++ new-fenserve/fendata/Main.hs	2007-06-20 14:56:10.000000000 +0300
@@ -15,6 +15,9 @@
 import qualified Control.Exception
 import qualified Data.Map as Map	
 import qualified Data.Set as Set
+
+import Network.URI (unEscapeString)
+
 import qualified System.IO.Unsafe
 
 main = stdHTTP [ debugFilter
@@ -112,8 +115,8 @@
                                , Exp "getField" ( f, Exp "var" $ I (0::Int) )))))
                                
   , h (Prefix ["potion"]) GET $ ok $ \[s] () -> respond $ 
-        either id id $ evaluate $ html $ header & let exp = readExp s in
-          ( renderExp getPotion exp
+        either id id $ evaluate $ html $ header & let exp = readExp $ unEscapeString s in
+          ( renderExp exp
           , hr
           , renderValues $ runExp [] exp )
   ]
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs	2007-06-20 14:56:10.000000000 +0300
+++ new-fenserve/fendata/Potions.hs	2007-06-20 14:56:10.000000000 +0300
@@ -43,6 +43,8 @@
     stringCase (SExp s []) = s
     
     expCase :: (?db :: DB, ?time :: Int64) => SExp -> Exp
+    expCase (SExp "question" [ty]) = Question (fromSExp ty)
+    expCase (SExp "focus" [exp]) = Focus (fromSExp exp)
     expCase (SExp name args) = f (getPotion name) where
         f (Potion _ (_ :: t -> (r, [Values] -> Values))) =
             Exp name (fromSExps args :: t)
@@ -77,13 +79,16 @@
     f (SExp n xs) (c:cs) = f (SExp (n++[c]) xs) cs
     
 showExp = f . toSExp where
-    f (SExp n []) = n
-    f (SExp n xs) = n ++ "(" ++ (concat $ intersperse "," $ map f xs) ++ ")"
+    f (SExp n []) = e n
+    f (SExp n xs) = e n ++ "(" ++ (concat $ intersperse "," $ map f xs) ++ ")"
+    e (c:cs) | c `elem` "\\(,)" = '\\' : c : e cs | otherwise = c : e cs
+    e [] = []
     
  
 mint ty (f, exec) = (I $ mintVar ty $ \var -> ren (f var), exec)
 
 runExp :: (?db :: DB, ?time :: Int64) => [Values] -> Exp -> Values
+runExp env (Focus e) = runExp env e
 runExp env (Exp name arg) = f (getPotion name) where
     f (Potion _ g) = snd (g $ fromJust $ cast arg) env
         
@@ -95,15 +100,15 @@
     
 instance RenderOne E where
      renderOne (E i e) = 
-         local (\env -> env { envPath = envPath env ++ [i] }) (renderExp' getPotion e)
+         local (\env -> env { envPath = envPath env ++ [i] }) (renderExp' e)
          
 
-renderExp :: (?db :: DB, ?time :: Int64) => (String -> Potion) -> Exp -> HTML
-renderExp getPotion exp = potion $ fst $ f [] (HTML "") $ execWriter $ flip runStateT 0 $ runReaderT (renderExp' getPotion exp) $ Env [] [] exp where
+renderExp :: (?db :: DB, ?time :: Int64) => Exp -> HTML
+renderExp exp = potion $ fst $ f [] (HTML "") $ execWriter $ flip runStateT 0 $ runReaderT (renderExp' exp) $ Env [] [] exp where
     potion = tag "span" [P "class" "potion"]
     lnk p = tag "a"
       [ P "class" "editLink"
-      , P "href" $ "/path/" ++ showExp (focusPath p exp) ]
+      , P "href" $ "/potion/" ++ showExp (focusPath p exp) ]
       
     f p h ((q,i):(r,j):xs) | q == r = f p h ((q,i&j):xs)
     f p h ((q,i):xs) | p == q           = f p (h & lnk p i) xs
@@ -111,8 +116,10 @@
                                            in f p (h & potion i') xs'
     f p h xs = (h,xs)
     
-renderExp' :: (?db :: DB, ?time :: Int64) => (String -> Potion) -> Exp -> RenderExp ()
-renderExp' getPotion exp@(Exp n arg) = f (getPotion n) where
+renderExp' :: (?db :: DB, ?time :: Int64) => Exp -> RenderExp ()
+renderExp' (Question ty) = ren ( "[which ", renderType ty, "?]" )
+renderExp' (Focus exp) = ren ( I $ E 0 exp )
+renderExp' exp@(Exp n arg) = f (getPotion n) where
     f (Potion _ f) = let (r,_) = f (fromMaybe (error "renderExp") $ cast arg) in ren r