[Fencommits] fenserve: improve code that parses expressions in URIs
Benja Fallenstein
benja.fallenstein at gmail.com
Sat Jun 16 23:39:53 EEST 2007
Sat Jun 16 23:39:39 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* improve code that parses expressions in URIs
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-06-16 23:39:53.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-06-16 23:39:53.000000000 +0300
@@ -95,9 +95,9 @@
, catFor (Map.elems $ dbCategories ?db) $ \(Category cat name fs) ->
( h3 ("Category: ", name)
, renderValues $ runExp [] $ Exp "tableView"
- ( Exp "allItems" cat
+ ( Exp "allItems" (I cat)
, for fs $ \f -> ( fieldName $ getField f
- , Exp "getField" ( f, Exp "var" (0::Int) )))))
+ , Exp "getField" ( f, Exp "var" $ I (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-16 23:39:53.000000000 +0300
+++ new-fenserve/fendata/Potions.hs 2007-06-16 23:39:53.000000000 +0300
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fglasgow-exts -fno-monomorphism-restriction #-}
+{-# OPTIONS_GHC -fglasgow-exts -fno-monomorphism-restriction -fallow-undecidable-instances -fallow-overlapping-instances #-}
module Potions where
@@ -26,31 +26,34 @@
data Order = Asc | Desc
deriving (Read, Show, Typeable, Data, Eq, Ord)
-
-readExp :: (?db :: DB, ?time :: Int64) => String -> Exp
-readExp = evalState parseExp . filter (not . null) . tokenize where
- parseExp :: (?db :: DB, ?time :: Int64, Data a) => State [String] a
- parseExp = otherCase `extR` stringCase `extR` expCase
-
- tokenize (c:cs) | c `elem` ",()" = "" : tokenize cs
- | (t:ts) <- tokenize cs = (c:t):ts
- tokenize [] = [""]
- pop = do x:xs <- get; put xs; return x
- stringCase = pop
+
+instance FromSExps () where fromSExps [] = ()
+instance (Tuple x xs xxs, Data x, FromSExps xs) => FromSExps xxs where
+ fromSExps (x:xs) = fromSExp x .*. fromSExps xs
+
+fromSExp :: (?db :: DB, ?time :: Int64, Data a) => SExp -> a
+fromSExp = otherCase `extR` stringCase `extR` expCase where
+ stringCase (SExp s []) = s
- 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)
+ expCase :: (?db :: DB, ?time :: Int64) => SExp -> Exp
+ expCase (SExp name args) = f (getPotion name) where
+ f (Potion _ (_ :: t -> (r, [Values] -> Values))) =
+ Exp name (fromSExps args :: t)
- 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 <- case dataTypeRep ty of
- AlgRep [c] -> return c
- _ -> liftM (fromMaybe (error "bad arg") . readConstr ty) pop
- gunfold k return c
+ otherCase :: (?db :: DB, ?time :: Int64, Data a) => SExp -> a
+ otherCase (SExp name args) =
+ fix $ \r -> snd $ gunfold k (\x -> (args, x)) $ c (dataTypeOf r) where
+ k (x:xs, f) = (xs, f $ fromSExp x)
+ c t = fromMaybe (error $ "not found: "++name) $ readConstr t name
+
+readExp = fromSExp . head . fst . f z where
+ z = SExp "" []; f e "" = ([e], ""); f e (')':cs) = ([e], cs)
+ f (SExp n xs) ('(':cs) = let (xs',cs') = f z cs in f (SExp n (xs++xs')) cs'
+ f e (',':cs) = let (xs,cs') = f z cs in (e:xs,cs')
+ f (SExp n xs) ('\\':c:cs) = f (SExp (n++[c]) xs) cs
+ f (SExp n xs) (c:cs) = f (SExp (n++[c]) xs) cs
+
mint ty (f, exec) = (I $ mintVar ty $ \var -> ren (f var), exec)
@@ -63,11 +66,11 @@
(p:_) -> p; [] -> error $ "Potion not found: " ++ name
potions =
- [ Potion "var" $ \i ->
+ [ Potion "var" $ \(I i) ->
( ( varType i, " ", varName i )
, \env -> env !! i )
- , Potion "literal" $ \values ->
+ , Potion "literal" $ \(I values) ->
( I $ renderValues values
, \env -> values )
@@ -82,7 +85,7 @@
( ( "the ", fieldName $ getField field, " of ", E 0 exp )
, \env -> do ItemValue _ item <- runExp env exp; getValue item field )
- , Potion "allItems" $ \cat ->
+ , Potion "allItems" $ \(I cat) ->
( ( "all the ", plural $ catName $ getCategory cat, " in the database" )
, \_ -> map (ItemValue cat) $ map itemId $ getItems cat )
@@ -115,15 +118,15 @@
return $ BooleanValue $ case op of
Lt->x<y; Le->x<=y; Eq->x==y; Ge->x>=y; Gt->x>y )
- , Potion "sum" $ \exp ->
+ , Potion "sum" $ \(I exp) ->
( ( "the sum of ", E 0 exp )
, \env -> [NumberValue $ sum $ map numberValue $ runExp env exp] )
- , Potion "product" $ \exp ->
+ , Potion "product" $ \(I exp) ->
( ( "the product of ", E 0 exp )
, \env -> [NumberValue $ product $ map numberValue $ runExp env exp] )
- , Potion "count" $ \exp ->
+ , Potion "count" $ \(I exp) ->
( ( "the number of ", E 0 exp )
, \env -> [NumberValue $ fromIntegral $ length $ runExp env exp] )
diff -rN -u old-fenserve/fendata/Types.hs new-fenserve/fendata/Types.hs
--- old-fenserve/fendata/Types.hs 2007-06-16 23:39:53.000000000 +0300
+++ new-fenserve/fendata/Types.hs 2007-06-16 23:39:53.000000000 +0300
@@ -12,6 +12,7 @@
import Control.Monad.State
import Control.Monad.Writer (Writer)
+import Data.Int
import Data.Generics -- (Typeable, Typeable1, Data)
import Data.Map (Map)
import qualified Data.Map as Map
@@ -143,10 +144,14 @@
type RenderExp = ReaderT Env :$$: StateT Int :$$: Writer HTML
-data Potion = forall a r. (Data a, Ren r) =>
+data SExp = SExp String [SExp]
+
+class FromSExps a where fromSExps :: (?db :: DB, ?time :: Int64) => [SExp] -> a
+
+data Potion = forall a r. (Data a, FromSExps a, Ren r) =>
Potion String (a -> (r, [Values] -> Values))
-data Exp = forall a. (Data a) => Exp String a
+data Exp = forall a. (Data a, FromSExps a) => Exp String a
| Question Type | Focus Exp
deriving Typeable
More information about the Fencommits
mailing list