[Fencommits] fenserve: start working on fendata demo
Benja Fallenstein
benja.fallenstein at gmail.com
Tue May 15 19:08:58 EEST 2007
Tue May 15 19:08:31 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* start working on fendata demo
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/fendata/Main.hs 2007-05-15 19:08:58.000000000 +0300
@@ -0,0 +1,148 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+import HAppS hiding (Body, getPath)
+import Control.Monad.State hiding (State)
+import Data.Generics (Typeable)
+import Data.Binary hiding (get,put)
+import Data.Maybe (fromMaybe)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+type Id = Int
+
+data Item = Item { itemFields :: Map String String, itemCategories :: Set String }
+ deriving (Read, Show, Typeable)
+
+data Type = Type { typeQuestion :: String }
+ deriving (Read, Show, Typeable)
+
+catType name = Type ("which " ++ name ++ "?")
+
+data Fun = Fun [Type] [String] Exp
+ | FieldFun String String
+ | CatFun String
+ deriving (Read, Show, Typeable)
+
+funTypes (Fun ts _ _) = ts
+funTypes (FieldFun cat _) = [catType cat]
+funTypes (CatFun _) = []
+
+funParts (Fun _ ps _) = ps
+funParts (FieldFun _ name) = ["the "++name++" of ", ""]
+funParts (CatFun cat) = ["all " ++ cat ++ "s"]
+
+data Exp = Call Fun [Maybe Exp]
+ | Var Int
+ | Forall Int Exp Exp
+ | HTML [Exp]
+ | Str String
+ deriving (Read, Show, Typeable)
+
+renderExp :: Exp -> String
+renderExp (Call fun args) = f (funTypes fun) (funParts fun) args where
+ f [] [x] _ = x
+ f (t:ts) (x:xs) (y:ys) =
+ x ++ maybe ("[" ++ typeQuestion t ++ "]") renderExp y ++ f ts xs ys
+renderExp (Var i) = "<i>" ++ [toEnum (fromEnum 'a' + i)] ++ "</i>"
+
+isComplete :: Exp -> Bool
+isComplete (Call _ args) = all (maybe False isComplete) args
+isComplete (Forall _ exp body) = isComplete exp && isComplete body
+isComplete (Var _) = True
+isComplete (HTML exps) = all isComplete exps
+isComplete (Str _) = True
+
+type Env = Map Int Value
+type Value = [String]
+
+runExp :: (?state :: State) => Env -> Exp -> Value
+runExp env (Call fn args) = runFun fn $
+ map (runExp env . fromMaybe (error "foo")) args
+runExp env (Forall v exp body) = [concatMap f (runExp env exp)] where
+ f val = head $ runExp (Map.insert v [val] env) body
+runExp env (Var i) = env Map.! i
+runExp env (HTML exps) = [concatMap (head . runExp env) exps]
+runExp _ (Str s) = [s]
+
+runFun (Fun _ _ body) args =
+ runExp (Map.fromList [(i, args!!i) | i <- [0..length args-1]]) body
+runFun (FieldFun cat name) [items] = map (f . read) items where
+ f item = itemFields (stateItems ?state Map.! item) Map.! name
+runFun (CatFun cat) [] =
+ [show n | (n, Item _ cs) <- Map.toList (stateItems ?state), cat `Set.member` cs]
+
+data State = State { stateItems :: Map Id Item,
+ stateSchema :: Map String [String] }
+ deriving (Read, Show, Typeable)
+
+instance Binary State where
+
+instance StartState State where
+ startStateM = return $ flip State
+ (Map.fromList [("post", ["title", "author", "body", "date"])]) $
+ Map.fromList [
+ (0, Item (Map.fromList [("title", "Hello world!"),
+ ("author", "Me"),
+ ("body", "Here we come."),
+ ("date", "2007-05-15")])
+ (Set.fromList ["post"]))
+ , (1, Item (Map.fromList [("title", "Hello worlds!"),
+ ("author", "Us"),
+ ("body", "Here I come."),
+ ("date", "2007-05-15")])
+ (Set.fromList ["post"]))
+ ]
+
+potion = Forall 0 (Call (CatFun "post") []) $
+ HTML [Str "<h2>", Call (FieldFun "post" "title") v, Str "</h2>\n",
+ Str "<p>Author: ", Call (FieldFun "post" "author") v,
+ Str "<p>", Call (FieldFun "post" "body") v,
+ Str "<hr>"]
+ where v = [Just $ Var 0]
+
+view = do
+ (state :: State) <- get
+ let category (name,fields) = "<h3>" ++ name ++ "</h3>\n"
+ ++ concatMap field fields
+ ++ "<p>Add field: "
+ ++ "<form method=post action=addfield>"
+ ++ "<input type=text name=name>"
+ ++ "<input type=hidden name=category value=" ++ name ++ ">"
+ ++ "</form>"
+ field name = name ++ "<br>\n"
+ respond $ "<h2>Categories</h2>"
+ ++ "<p>Add category: "
+ ++ "<form method=post action=addcat>"
+ ++ "<input type=text name=name>"
+ ++ "</form>"
+ ++ concatMap category (Map.toList $ stateSchema state)
+
+instance FromMessage (String,String) where
+ fromMessageM m = do cat <- lookM m "category"; name <- lookM m "name"
+ return (cat, name)
+
+instance FromMessage String where
+ fromMessageM m = lookM m "name"
+
+addField cat name = do
+ state <- get
+ let fs = stateSchema state Map.! cat
+ put $ state { stateSchema = Map.insert cat (fs ++ [name]) (stateSchema state) }
+ view
+
+addCategory cat = do
+ state <- get
+ put $ state { stateSchema = Map.insert cat [] $ stateSchema state}
+ view
+
+main = stdHTTP [ debugFilter
+ , h ["potion"] GET $ ok $ \() () -> do
+ s <- get
+ respond $ head $ let ?state=s in runExp Map.empty potion
+ , h () GET $ ok $ \() () -> view
+ , h ["addfield"] POST $ ok $ \() (cid,name) -> addField cid name
+ , h ["addcat"] POST $ ok $ \() name -> addCategory name
+ ]
+
diff -rN -u old-fenserve/fendata/Makefile new-fenserve/fendata/Makefile
--- old-fenserve/fendata/Makefile 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/fendata/Makefile 2007-05-15 19:08:58.000000000 +0300
@@ -0,0 +1,29 @@
+
+PREFIX=~/inst
+CONFIGURE_OPTS=--user --prefix $(PREFIX)
+
+all: build
+
+.setup-config:
+ runhaskell Setup.lhs configure $(CONFIGURE_OPTS)
+
+configure:
+ runhaskell Setup.lhs configure $(CONFIGURE_OPTS)
+
+build: .setup-config
+ runhaskell Setup.lhs build
+
+install:
+ runhaskell Setup.lhs install
+
+run: build install
+ ./dist/build/fendata/fendata $(ARGS)
+
+import: build install
+ ./dist/build/fendata-import/fendata-import $(ARGS)
+
+reset:
+ rm -rf fendata_state fendata_error.log
+
+clean:
+ runhaskell Setup.lhs clean
diff -rN -u old-fenserve/fendata/Setup.lhs new-fenserve/fendata/Setup.lhs
--- old-fenserve/fendata/Setup.lhs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/fendata/Setup.lhs 2007-05-15 19:08:58.000000000 +0300
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMainWithHooks defaultUserHooks
diff -rN -u old-fenserve/fendata/fendata.cabal new-fenserve/fendata/fendata.cabal
--- old-fenserve/fendata/fendata.cabal 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/fendata/fendata.cabal 2007-05-15 19:08:58.000000000 +0300
@@ -0,0 +1,11 @@
+Name: fendata
+Version: 0.1
+License: GPL
+License-file: LICENSE
+Author: Benja Fallenstein
+Maintainer: fenfire-dev at nongnu.org
+Build-Depends: base, mtl, network, HAppS, binary
+
+Executable: fendata
+Main-Is: Main.hs
+
More information about the Fencommits
mailing list