[Fencommits] fenserve: make it possible to enter potions as URIs and get back the rendered value of the potion

[Benja Fallenstein]

Fri Jun 15 20:56:05 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * make it possible to enter potions as URIs and get back the rendered value of the potion
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs	2007-06-15 20:56:16.000000000 +0300
+++ new-fenserve/fendata/Main.hs	2007-06-15 20:56:16.000000000 +0300
@@ -98,4 +98,6 @@
               ( Exp "allItems" cat
               , for fs $ \f -> ( fieldName $ getField f
                                , Exp "getField" ( f, Exp "var" (0::Int) )))))
+                               
+  , page ["potion"] "Potion" $ renderValues $ runExp [] $ readExp $ lookE "exp"
   ]
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs	2007-06-15 20:56:16.000000000 +0300
+++ new-fenserve/fendata/Potions.hs	2007-06-15 20:56:16.000000000 +0300
@@ -8,10 +8,13 @@
 import Types
 import Rendering
 
+import Control.Monad.Fix
+import Control.Monad.State
+
 import Data.Int
 import Data.Generics
 import Data.List
-import Data.Maybe (fromJust)
+import Data.Maybe (fromJust, fromMaybe)
 
 import System.Time
 
@@ -24,12 +27,35 @@
 data Order = Asc | Desc
     deriving (Read, Show, Typeable, Data, Eq, Ord)
 
+readExp :: (?db :: DB, ?time :: Int64) => String -> Exp
+readExp = evalState parseExp . words where
+    parseExp :: (?db :: DB, ?time :: Int64, Data a) => State [String] a
+    parseExp = otherCase `extR` stringCase `extR` expCase
+    
+    pop = do x:xs <- get; put xs; return x
+    stringCase = pop
+    
+    expCase :: (?db :: DB, ?time :: Int64) => State [String] Exp
+    expCase = pop >>= f . getPotion where
+        f (Potion name (_ :: a -> (r, [Values] -> Values))) =
+            parseExp >>= \arg -> return $ Exp name (arg::a)
+        
+    otherCase :: Data a => State [String] a
+    otherCase = mfix $ \r -> do 
+        let ty = dataTypeOf r; k m = do m -> f; parseExp -> x; return (f x)
+        c <- if maxConstrIndex ty > 1 then liftM (fromJust . readConstr ty) pop
+                                      else return $ head $ dataTypeConstrs ty
+        gunfold k return c
+ 
 mint ty (f, exec) = (I $ mintVar ty $ \var -> ren (f var), exec)
 
 runExp :: (?db :: DB, ?time :: Int64) => [Values] -> Exp -> Values
-runExp env (Exp name arg) = f potions where
-    f (Potion n g : xs) | n /= name = f xs | otherwise =
-        snd (g $ fromJust $ cast arg) env
+runExp env (Exp name arg) = f (getPotion name) where
+    f (Potion _ g) = snd (g $ fromJust $ cast arg) env
+        
+getPotion :: (?db :: DB, ?time :: Int64) => String -> Potion
+getPotion name = case filter (\(Potion n _) -> n == name) potions of
+                     (p:_) -> p; [] -> error $ "Potion not found: " ++ name
              
 potions =
   [ Potion "var" $ \i ->
diff -rN -u old-fenserve/fendata/Types.hs new-fenserve/fendata/Types.hs
--- old-fenserve/fendata/Types.hs	2007-06-15 20:56:16.000000000 +0300
+++ new-fenserve/fendata/Types.hs	2007-06-15 20:56:16.000000000 +0300
@@ -143,10 +143,10 @@
 type RenderExp = ReaderT Env :$$: StateT Int :$$: Writer HTML
                                
 
-data Potion = forall a r. (Data a, Read a, Show a, Ren r) => 
+data Potion = forall a r. (Data a, Ren r) => 
               Potion String (a -> (r, [Values] -> Values))
               
-data Exp = forall a. (Data a, Read a, Show a) => Exp String a
+data Exp = forall a. (Data a) => Exp String a
          | Question Type | Focus Exp
     deriving Typeable
 
@@ -157,6 +157,10 @@
     
 instance Read Exp where
 instance Show Exp where
+    show (Exp name arg) = "(Exp " ++ show name ++ " " ++ gshow arg ++ ")"
+    show (Question ty) = "(Question " ++ show ty ++ ")"
+    show (Focus exp) = "(Focus " ++ show exp ++ ")"
 instance Data Exp where
 instance Eq Exp where
 instance Ord Exp where
+