[Fencommits] fenserve: code for showing exps using the URI syntax for potions

[Benja Fallenstein]

Wed Jun 20 14:37:28 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * code for showing exps using the URI syntax for potions
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs	2007-06-20 14:37:48.000000000 +0300
+++ new-fenserve/fendata/Potions.hs	2007-06-20 14:37:48.000000000 +0300
@@ -9,8 +9,9 @@
 import Rendering
 
 import Control.Monad.Fix
-import Control.Monad.Reader (local)
+import Control.Monad.Reader (local, runReaderT)
 import Control.Monad.State
+import Control.Monad.Writer (execWriter)
 
 import Data.Int
 import Data.Generics
@@ -32,6 +33,10 @@
 instance FromSExps () where fromSExps [] = ()
 instance (Tuple x xs xxs, Data x, FromSExps xs) => FromSExps xxs where
     fromSExps (x:xs) = fromSExp x .*. fromSExps xs
+    
+instance ToSExps () where toSExps () = []
+instance (Tuple x xs xxs, Data x, ToSExps xs) => ToSExps xxs where
+    toSExps xxs | (x,xs) <- tsplit1 xxs = toSExp x : toSExps xs
 
 fromSExp :: (?db :: DB, ?time :: Int64, Data a) => SExp -> a
 fromSExp = otherCase `extR` stringCase `extR` expCase where
@@ -51,6 +56,18 @@
             k (x:xs, f) = (xs, f $ fromSExp x)
             c | name == "" && maxConstrIndex t == 1 = indexConstr t 1
               | True = fromMaybe (error $ "not found: "++name) $ readConstr t name
+
+toSExp :: (?db :: DB, ?time :: Int64, Data a) => a -> SExp
+toSExp = otherCase `extQ` stringCase `extQ` expCase where
+    stringCase s = SExp s []
+    
+    expCase :: (?db :: DB, ?time :: Int64) => Exp -> SExp
+    expCase (Exp name args) = SExp name (toSExps args)
+    expCase (Question ty) = SExp "question" [toSExp ty]
+    expCase (Focus exp) = SExp "focus" [toSExp exp]
+        
+    otherCase :: (?db :: DB, ?time :: Int64, Data a) => a -> SExp
+    otherCase x = SExp (showConstr (toConstr x)) (gmapQ toSExp x)
             
 readExp = fromSExp . head . fst . f z where
     z = SExp "" [];  f e "" = ([e], "");  f e (')':cs) = ([e], cs)
@@ -59,6 +76,10 @@
     f (SExp n xs) ('\\':c:cs) = f (SExp (n++[c]) xs) cs
     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) ++ ")"
+    
  
 mint ty (f, exec) = (I $ mintVar ty $ \var -> ren (f var), exec)
 
@@ -75,6 +96,25 @@
 instance RenderOne E where
      renderOne (E i e) = 
          local (\env -> env { envPath = envPath env ++ [i] }) (renderExp' getPotion 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
+    potion = tag "span" [P "class" "potion"]
+    lnk p = tag "a"
+      [ P "class" "editLink"
+      , P "href" $ "/path/" ++ 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
+                     | p `isPrefixOf` q = let (i',xs') = f q (HTML "") ((q,i):xs)
+                                           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
+    f (Potion _ f) = let (r,_) = f (fromMaybe (error "renderExp") $ cast arg) in ren r
+
 
 potions =
   [ Potion "var" $ \(I i) ->
diff -rN -u old-fenserve/fendata/Rendering.hs new-fenserve/fendata/Rendering.hs
--- old-fenserve/fendata/Rendering.hs	2007-06-20 14:37:48.000000000 +0300
+++ new-fenserve/fendata/Rendering.hs	2007-06-20 14:37:48.000000000 +0300
@@ -83,23 +83,3 @@
 instance (RenderOne x, Ren xs, Tuple x xs t) => Ren t where
     ren t | (x,xs) <- tsplit1 t = renderOne x >> ren xs
 
-
-showExp = show
-
-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
-    potion = tag "span" [P "class" "potion"]
-    lnk p = tag "a"
-      [ P "class" "editLink"
-      , P "href" $ "/path/" ++ 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
-                     | p `isPrefixOf` q = let (i',xs') = f q (HTML "") ((q,i):xs)
-                                           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
-    f (Potion _ f) = let (r,_) = f (fromMaybe (error "renderExp") $ cast arg) in ren r
-
diff -rN -u old-fenserve/fendata/Types.hs new-fenserve/fendata/Types.hs
--- old-fenserve/fendata/Types.hs	2007-06-20 14:37:48.000000000 +0300
+++ new-fenserve/fendata/Types.hs	2007-06-20 14:37:48.000000000 +0300
@@ -147,11 +147,12 @@
 data SExp = SExp String [SExp]
 
 class FromSExps a where fromSExps :: (?db :: DB, ?time :: Int64) => [SExp] -> a
+class ToSExps a where toSExps :: (?db :: DB, ?time :: Int64) => a -> [SExp]
 
-data Potion = forall a r. (Data a, FromSExps a, Ren r) => 
+data Potion = forall a r. (Data a, FromSExps a, ToSExps a, Ren r) => 
               Potion String (a -> (r, [Values] -> Values))
               
-data Exp = forall a. (Data a, FromSExps a) => Exp String a
+data Exp = forall a. (Data a, FromSExps a, ToSExps a) => Exp String a
          | Question Type | Focus Exp
     deriving Typeable