diff --git a/Blog/Makefile b/Blog/Makefile index 892b63a..370f4ba 100644 --- a/Blog/Makefile +++ b/Blog/Makefile @@ -1,10 +1,7 @@ GHC=ghc $(GHCFLAGS) --make -O2 -optc-O3 -i. -i../ TEMPLATES=Templates.hs -all: Templates Blog - -Templates: TemplateGen - ../Framework/TGenerator/TemplateGen templates/ $(TEMPLATES) +all: Blog TemplateGen: make -C ../Framework/TGenerator/ diff --git a/Blog/templates/403.html b/Blog/templates/403.html index 22b4058..81c343a 100644 --- a/Blog/templates/403.html +++ b/Blog/templates/403.html @@ -1,12 +1,14 @@ +error403(currentError :: String) + <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> <head> - <title>{{error}}</title> + <title>{{currentError}}</title> <meta name='author' content='Portnov'> </head> <body> - <h1>{{error}}</h1> + <h1>{{currentError}}</h1> <p>Sorry, authentitication required.</p> </body> diff --git a/Blog/templates/404.html b/Blog/templates/404.html index 4fd78cf..bcbc86a 100644 --- a/Blog/templates/404.html +++ b/Blog/templates/404.html @@ -1,3 +1,5 @@ +error404(currentError :: String, url :: String, request :: Request) + <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> <head> diff --git a/Blog/templates/blogposts.html b/Blog/templates/blogposts.html index fc0c7b2..8aafe44 100644 --- a/Blog/templates/blogposts.html +++ b/Blog/templates/blogposts.html @@ -1,3 +1,5 @@ +blogposts(username :: String, message :: String, posts :: [Post], comments :: [Comment], pager :: String) + <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> <head> diff --git a/Blog/templates/delconfirm.html b/Blog/templates/delconfirm.html index 1fb8734..3625707 100644 --- a/Blog/templates/delconfirm.html +++ b/Blog/templates/delconfirm.html @@ -1,3 +1,5 @@ +delconfirm(myurl :: String, object :: String) + <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> <head> diff --git a/Blog/templates/editpost.html b/Blog/templates/editpost.html index 886ee1f..658e153 100644 --- a/Blog/templates/editpost.html +++ b/Blog/templates/editpost.html @@ -1,3 +1,5 @@ +editpost(invalid :: Bool, form :: String) + <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> <head> diff --git a/Blog/templates/i18ntest.html b/Blog/templates/i18ntest.html index 54a6c0b..7499436 100644 --- a/Blog/templates/i18ntest.html +++ b/Blog/templates/i18ntest.html @@ -1,3 +1,5 @@ +i18ntest(text :: String) + <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> <head> diff --git a/Blog/templates/login.html b/Blog/templates/login.html index 47cf468..14c8036 100644 --- a/Blog/templates/login.html +++ b/Blog/templates/login.html @@ -1,3 +1,5 @@ +login(message :: String, form :: String) + <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> <head> diff --git a/Blog/templates/newpost.html b/Blog/templates/newpost.html index 258ae9f..e8f0ebc 100644 --- a/Blog/templates/newpost.html +++ b/Blog/templates/newpost.html @@ -1,3 +1,5 @@ +newpost(invalid :: Bool, form :: String) + <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> <head> diff --git a/Blog/templates/onepost.html b/Blog/templates/onepost.html index 775862a..f68e9b9 100644 --- a/Blog/templates/onepost.html +++ b/Blog/templates/onepost.html @@ -1,3 +1,5 @@ +onepost(post :: Post, comments :: [Comment], form :: String, pager :: String) + <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> <head> diff --git a/Blog/templates/posts2.html b/Blog/templates/posts2.html index 7a38c59..3cf3061 100644 --- a/Blog/templates/posts2.html +++ b/Blog/templates/posts2.html @@ -1,3 +1,5 @@ +posts2(posts :: [Post], pager :: String) + <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> <head> diff --git a/Blog/templates/register.html b/Blog/templates/register.html index af00789..750f49e 100644 --- a/Blog/templates/register.html +++ b/Blog/templates/register.html @@ -1,3 +1,5 @@ +register(message :: String, form :: String) + <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> <head> diff --git a/Blog/templates/testform.html b/Blog/templates/testform.html index 52fdac7..cbcb9ca 100644 --- a/Blog/templates/testform.html +++ b/Blog/templates/testform.html @@ -1,3 +1,5 @@ +testform() + <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> <head> diff --git a/Framework/TEngine/TemplateFuncs.hs b/Framework/TEngine/TemplateFuncs.hs index b4476e8..f74a9e8 100644 --- a/Framework/TEngine/TemplateFuncs.hs +++ b/Framework/TEngine/TemplateFuncs.hs @@ -1,12 +1,5 @@ {-# LANGUAGE NoMonomorphismRestriction #-} -module Framework.TEngine.TemplateFuncs - (bold, - uppercase,lowercase, - evenP,oddP, - list, separateWith, - children, - mapF, isContainerTrue - ) where +module Framework.TEngine.TemplateFuncs where import Data.Char import Data.List @@ -15,43 +8,6 @@ import qualified Data.Map as M import Framework.TEngine.Types -- import qualified Framework.Pager as Pager -bold :: Maybe TContainer -> String -bold = apply $ \s -> "<strong>"++s++"</strong>" - -italic :: Maybe TContainer -> String -italic = apply $ \s -> "<em>"++s++"</em>" - -uppercase :: Maybe TContainer -> String -uppercase = apply $ map toUpper -lowercase :: Maybe TContainer -> String -lowercase = apply $ map toLower - -evenP :: Maybe TContainer -> Bool -evenP = apply (even::Int -> Bool) -oddP :: Maybe TContainer -> Bool -oddP = apply (odd::Int -> Bool) - --- | Show a list, transformed by given function, with given separator -list :: String -- ^ Items separator (say, \"; \") - -> (String -> String) -- ^ Modify each item - -> Maybe TContainer - -> String -list sep f (Just (C lst)) = intercalate sep $ map transform (mkList lst) - where transform = \(C x) -> f (stringField 1 x) -list _ _ Nothing = "" - --- | Show a list with given separator -separateWith :: String -> Maybe TContainer -> String -separateWith s = list s id - --- | List of related (children) models -children :: String -- ^ Name of foreign key field in the child model - -> TContainer -- ^ Parent model - -> TContainer -- ^ List of children models -children key (C x) = case lookup key (getRelated x) of - Just lst -> C lst - Nothing -> C ([]::[Int]) - {- pager :: TContainer -- ^ List of models -> TContainer -- ^ URL @@ -67,16 +23,6 @@ pager (C lst) (C url) (C p) = Pager.genpager url' pages p' n (C first) = getPerPage first -} --- | Apply given function (render) for each item in the list (contained in TContainer). --- Used in Templates. -mapF :: String -- ^ Name of list-item variable - -> (M.Map String TContainer -> String) -- ^ Rendering function - -> M.Map String TContainer -- ^ Current context (variables) - -> TContainer -- ^ A list to iterate - -> String -mapF k f s (C lst) = concat $ map f [M.insert "it" (C it) $ M.insert k v s | (it,v) <- zip ([1..]::[Int]) (mkList lst)] - -isContainerTrue :: Maybe TContainer -> Bool -isContainerTrue (Just (C x)) = isTrue x -isContainerTrue Nothing = False +mapF :: (Int -> a -> String) -> [a] -> String +mapF f list = concat [f i x | (i,x) <- zip [1..] list] diff --git a/Framework/TEngine/Types.hs b/Framework/TEngine/Types.hs index 45d77a1..f6ad0e3 100644 --- a/Framework/TEngine/Types.hs +++ b/Framework/TEngine/Types.hs @@ -3,6 +3,33 @@ module Framework.TEngine.Types where import Data.List +class ToString a where + toString :: a -> String + +instance ToString Int where + toString = show + +instance ToString Integer where + toString = show + +instance ToString Double where + toString = show + +instance ToString String where + toString = id + +class ToBool a where + toBool :: a -> Bool + +instance ToBool Bool where + toBool = id + +instance (Num a) => ToBool a where + toBool x = x /= 0 + +instance ToBool [a] where + toBool = not . null + -- | Single item to render in template. class TemplateOne a where -- | Show @@ -20,159 +47,3 @@ class TemplateOne a where -- | Get number of items to put on one page getPerPage :: a -> Int getPerPage _ = 20 - --- | Multiple-valued item to render in template. -class (TemplateOne a) => TemplateItem a where - -- | Show - showT :: a -> String - -- | Get list of n'th integer fields in all items - intFields :: Int -> a -> [Int] - -- | Get list of n'th string fields in all items - stringFields :: Int -> a -> [String] - -- | Get list of n'th boolean fields in all items - boolFields :: Int -> a -> [Bool] - -- | Convert to a list - mkList :: a -> [TContainer] - -- | Check whether this item equivalent to True - isTrue :: a -> Bool - --- | Show TContainer -showC :: TContainer -> String -showC (C x) = showT x - -instance TemplateOne String where - showO = id - intField _ = read - stringField _ = id - boolField _ = not.null - -instance TemplateOne Int where - showO = show - intField _ = id - stringField _ = show - boolField _ = (/=0) - -instance TemplateOne Bool where - showO = show - intField _ x = if x then 1 else 0 - stringField _ = show - boolField _ = id - -instance (TemplateOne a) => TemplateOne [a] where - showO l = intercalate ", " (map showO l) - intField _ = length - stringField _ x = showO x - boolField _ = not.null - -instance (TemplateOne a) => TemplateItem a where - showT = showO - intFields n x = [intField n x] - stringFields n x = [stringField n x] - boolFields n x = [boolField n x] - mkList = error "undefined mkList for a" - isTrue = error "undefined isTrue for a" - -instance (TemplateOne a) => TemplateItem [a] where - showT l = intercalate ", " (map showO l) - intFields n = map (intField n) - stringFields n = map (stringField n) - boolFields n = map (boolField n) - mkList x = map C x - isTrue = not.null - -instance TemplateItem String where - showT s = s - intFields _ s = [read s] - stringFields _ s = [s] - boolFields _ s = [not $ null s] - mkList = error "undefined mkList for String" - isTrue = not.null - --- | Container type for any `renderable` value -data TContainer = forall a. (TemplateItem a) => C a - -------------------------------------------------------------------------------------------- -type Context = [(String,TContainer)] -------------------------------------------------------------------------------------------- - --- | Claims a fact that values of type @f@ can be `applied` to value of type --- @a@, resulting value of type @b@ -class Applicable f a b where - app :: Int -> f -> a -> b - --- | Same as `app 1' -apply :: (Applicable f a b) => f -> a -> b -apply = app 1 - --- | Simplest instance of this class -instance Applicable (a -> b) a b where - app _ f x = f x - -instance Applicable (a -> b) [a] [b] where - app _ f lst = map f lst - --- | @TContainer@ can have fields of such types -class FieldType a where - _field :: Int -> TContainer -> a - fzero :: a - -instance (FieldType b, Applicable f a b) => Applicable f (Maybe a) b where - app n f (Just x) = app n f x - app _ _ Nothing = fzero - -instance Applicable (Int -> a) TContainer a where - app n f (C x) = f (intField n x) - -instance Applicable (String -> a) TContainer a where - app n f (C x) = f (stringField n x) - -instance Applicable (Bool -> a) TContainer a where - app n f (C x) = f (boolField n x) - --- Next three instances allow to `apply` a function to two @TContainer@'s -instance Applicable (a -> b) TContainer b => Applicable (String -> a -> b) TContainer (TContainer -> b) where - app n op (C x) = \y -> app n (op (stringField n x)) y - -instance Applicable (a -> b) TContainer b => Applicable (Int -> a -> b) TContainer (TContainer -> b) where - app n op (C x) = \y -> app n (op (intField n x)) y - -instance Applicable (a -> b) TContainer b => Applicable (Bool -> a -> b) TContainer (TContainer -> b) where - app n op (C x) = \y -> app n (op (boolField n x)) y - --- Next three instances allow to `apply` a function to `simple` value and @TContainer@ -instance (TemplateOne a, FieldType a) => Applicable (String -> a -> b) a (TContainer -> b) where - app n op x = \y -> app n (op (_field n $ C x)) ((_field n y)::a) - -instance (TemplateOne a, FieldType a) => Applicable (Int -> a -> b) a (TContainer -> b) where - app n op x = \y -> app n (op (_field n $ C x)) ((_field n y)::a) - -instance (TemplateOne a, FieldType a) => Applicable (Bool -> a -> b) a (TContainer -> b) where - app n op x = \y -> app n (op (_field n $ C x)) ((_field n y)::a) - -idString :: String -> String -idString = id - -idInt :: Int -> Int -idInt = id - -idBool :: Bool -> Bool -idBool = id - -instance FieldType String where - _field n x = app n idString x - fzero = "" - -instance FieldType Int where - _field n x = app n idInt x - fzero = 0 - -instance FieldType Bool where - _field n x = app n idBool x - fzero = False - --- | Get a field from TContainer -field :: FieldType a => Int -- ^ Number of the field - -> Maybe TContainer - -> a -- ^ Type of field determined by return type -field n (Just x) = _field n x -field n Nothing = fzero diff --git a/Framework/TGenerator/Makefile b/Framework/TGenerator/Makefile index bc92af0..b06fb39 100644 --- a/Framework/TGenerator/Makefile +++ b/Framework/TGenerator/Makefile @@ -3,7 +3,7 @@ GHC=ghc --make -O2 -i. -i../../ all: TemplateGen TemplateGen: TemplateGen.hs TemplateParser.hs - $(GHC) -main-is TemplateGen.main TemplateGen.hs + $(GHC) TemplateGen.hs clean: rm TemplateGen diff --git a/Framework/TGenerator/TemplateGen.hs b/Framework/TGenerator/TemplateGen.hs index 9335738..f481adb 100644 --- a/Framework/TGenerator/TemplateGen.hs +++ b/Framework/TGenerator/TemplateGen.hs @@ -1,9 +1,9 @@ --- | Generator of Templates.hs -module TemplateGen where +module Framework.TGenerator.TemplateGen + (generateTemplates) + where -import Prelude hiding (readFile) -import System.IO hiding (readFile,hPutStrLn,hPutStr) -import System.IO.UTF8 +import Prelude +import System.IO import System.Environment import Data.List import Data.Char @@ -11,26 +11,31 @@ import Data.String.Utils import System.Directory import System.FilePath ((</>)) import Control.Monad +import Control.Monad.State +import Control.Monad.Trans import qualified Data.Map as M import Data.Hash +import Language.Haskell.TH import Framework.Utils -import TemplateParser +import Framework.TGenerator.TemplateParser -------------------------------------------------------------------------------------------------- --- Code generator +-- Data types -------------------------------------------------------------------------------------------------- +data FormatState = + FormatState { + delayed :: [TemplateFunction], + nestLevel :: Int, + current :: TemplateFunction } + +type GState a = StateT FormatState Q a + -------------------------------------------------------------------------------------------------- -- Generator's utilites -------------------------------------------------------------------------------------------------- -quote s = "\""++s++"\"" -getvar v = "maybe \"\" showC (M.lookup "++quote v++" pairs)" - -getlist [n] = "maybe (C ([]::[Int])) id (M.lookup "++quote n++" pairs)" -getlist ns = "maybe (C ([]::[Int])) ("++(unwords $ init ns)++") (M.lookup "++quote (last ns)++" pairs)" - instance Hashable Format where hash (Verbatim s) = hash s hash (Quote ss) = foldr combine (hash (1::Int)) $ map hash ss @@ -41,99 +46,178 @@ hash' lst = if null lst then "0" else show $ asWord64 $ hash lst -nl = "\n" - -mapS start f [] = ([], start) -mapS start f (x:xs) = (z:zs, res) - where y = f start x - z = fst y - t = mapS (snd y) f xs - zs = fst t - res = snd t - -joinMap f lst = (concat $ intersperse ", \n" $ (fst m), snd m) - where m = mapS M.empty f lst - -genTemplate :: String -> Template -> String -genTemplate name tpl = if name=="0" - then "" - else "render \""++name++"\" pairs = concat [\n" ++ (fst j) ++ "]" ++ nl ++ renderSubs ++ nl - where j = joinMap genFormat tpl - renderSubs = case M.assocs $ snd j of - [] -> "" - lst -> concat $ map (uncurry genTemplate) lst - -joinList lst = concat $ intersperse ",\n" $ map (" "++) $ map quote lst -quoteLines s = joinList $ map (replace "\"" "\\\"") $ lines s - -genquote xs = - if null fs - then getvar x - else "("++(unwords fs)++") (M.lookup "++(quote x)++" pairs)" - where - fs = init xs - x = last xs - -genquoteB xs = - if null fs - then "isContainerTrue (M.lookup "++(quote x)++" pairs)" - else "("++(unwords fs)++") (M.lookup "++(quote x)++" pairs)" - where - fs = init xs - x = last xs - -genFormat m (Verbatim s) = (quoteLines s, m) -genFormat m (Quote v) = (" "++genquote v, m) -genFormat m (ForTag (v:lst) tpl) = (" mapF "++(quote v)++" (render \""++ h ++"\") pairs $ "++(getlist lst), M.insert h tpl m) - where h = hash' tpl -genFormat m (IfTag v tpl1 tpl2) = (" render (if "++(genquoteB v)++" then "++(quote h1)++" else "++(quote h2)++") pairs", - M.insert h1 tpl1 $ M.insert h2 tpl2 m) - where h1 = hash' tpl1 - h2 = hash' tpl2 -genFormat m (Include s) = (" render "++(quote s)++" pairs", m) -genFormat m (IncludeVar v) = (" render ("++(getvar v)++") pairs", m) - -preamble h = do --- hPutStrLn h "{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, OverlappingInstances #-}" - hPutStrLn h "module Templates where" - hPutStrLn h "import qualified Data.Map as M" - hPutStrLn h "import Data.List" - hPutStrLn h "import Framework.Utils" - hPutStrLn h "import Framework.TEngine.Types" - hPutStrLn h "import Framework.TEngine.TemplateFuncs" - hPutStrLn h "import Models" - hPutStrLn h "" - hPutStrLn h "render :: String -> M.Map String TContainer -> String" - -endrender h = do - hPutStrLn h "render \"0\" _ = \"\"" - hPutStrLn h "render _ _ = \"<h1>No such template!</h1>\"" - ------------------------------------------------------------------------------------------------------------------------------------- --- +genType :: TemplateFunction -> Dec +genType (TF name sig _) = SigD (mkName name) (foldr arrow string types) + where + string = ConT (mkName "String") + types = map snd sig + arrow t1 t2 = AppT (AppT ArrowT t1) t2 + +genHeader :: TemplateFunction -> String +genHeader (TF name sig _) = name ++ " " ++ foldr next "" (map fst sig) + where + next x y = x ++ " " ++ y + +oneFunction :: GState [Dec] +oneFunction = do + tf <- gets current + body <- genFormats (templateBody tf) + let patterns = map (VarP . mkName . fst) (templateType tf) + tbody = NormalB (var "concat" `AppE` ListE body) + dec = FunD (mkName $ templateName tf) [Clause patterns tbody []] + return [genType tf, dec] + +pop :: GState Bool +pop = do + st <- get + case delayed st of + [] -> return False + (c:other) -> do + put $ st {current = c, delayed = other} + return True + +genTemplates :: GState [Dec] +genTemplates = do + name <- gets (templateName . current) + func <- oneFunction + b <- pop + if b + then do + other <- genTemplates + return $ func ++ other + else return func + +genTemplate :: TemplateFunction -> Q [Dec] +genTemplate tf = evalStateT genTemplates $ FormatState [] 0 tf + +quoteLines s = map (string . (++"\n")) (init ls) ++ [string (last ls)] + where + ls = lines s + +getIt :: GState String +getIt = do + level <- gets nestLevel + if level == 0 + then return "it" + else return ("it" ++ show level) + +delay :: Template -> [(String, Type)] -> GState Exp +delay template sig = do + st <- get + let h = hash' template + curSig = templateType (current st) + tplF = TF ("_" ++ h) (curSig ++ sig) template + st' = st {delayed = tplF: delayed st} + put st' + return $ var ("_" ++ h) + +delayIt :: Template -> String -> Type -> GState Exp +delayIt template var qType = do + it <- getIt + delay template [(it, ConT $ mkName "Int"), (var, qType)] + +genericQuote :: String -> [String] -> Exp +genericQuote _ [] = error "Internal error: quoting an empty list!" +genericQuote f [v] = (var f) `AppE` (var v) +genericQuote _ vars = + let fs = init vars + x = last vars + in foldr AppE (var x) $ map var fs + +boolQuote :: [String] -> Exp +boolQuote = genericQuote "toBool" + +varQuote :: [String] -> Exp +varQuote = genericQuote "toString" + +getVarType :: String -> GState Type +getVarType name = do + vars <- gets (templateType . current) + case lookup name vars of + Nothing -> fail $ "Unknown var: " ++ name + Just t -> return t + +fromListType :: Type -> GState Type +fromListType (AppT ListT tp) = return tp +fromListType t = notAList t + +getResultType :: Type -> Type +getResultType (AppT (AppT ArrowT _) t) = t +getResultType t = t + +notAList t = fail $ "Trying to iterate over non-list! Type: " ++ show t + +getListType :: [String] -> GState Type +getListType [] = error "Internal error: Iterating over what!?" +getListType [v] = do + listType <- getVarType v + fromListType listType +getListType (f:_) = do + let name = mkName f + lift $ do + (VarI _ tp _ _) <- reify name + case getResultType tp of + (AppT ListT t) -> return t + (AppT (ConT name) t) -> if nameBase name == "[]" then return t else notAList t + t -> notAList t + +var :: String -> Exp +var s = VarE (mkName s) + +string :: String -> Exp +string s = LitE (StringL s) + +genFormat :: Format -> GState [Exp] +genFormat (Verbatim s) = return (quoteLines s) +genFormat (Quote v) = return [varQuote v] +genFormat (ForTag (v:lst) tpl) = do + varType <- getListType lst + currentVars <- gets (map fst . templateType . current) + h <- delayIt tpl v varType + let fun = foldl AppE h $ map var currentVars + list = foldl1 AppE $ map var lst + return [var "mapF" `AppE` fun `AppE` list] +genFormat (IfTag v tpl1 tpl2) = do + currentVars <- gets (map fst . templateType . current) + h1 <- delay tpl1 [] + if null tpl2 + then return [CondE (boolQuote v) (foldl AppE h1 $ map var currentVars) (string "")] + else do + h2 <- delay tpl2 [] + return [(CondE (boolQuote v) h1 h2) `AppE` (foldl1 AppE $ map var currentVars)] +genFormat (Include s) = do + currentVars <- gets (map fst . templateType . current) + return [foldl AppE (var s) $ map var currentVars] +genFormat (IncludeVar v) = undefined + +genFormats :: [Format] -> GState [Exp] +genFormats formats = do + list <- mapM genFormat formats + return $ concat list + +----------------------------------------------------------------------------------------------------------------------------- + +searchTemplates :: String -> (String -> String -> Q [Dec]) -> Q [Dec] searchTemplates dir f = do - names <- getDirectoryContents dir + names <- runIO $ getDirectoryContents dir let properNames = filter (`notElem` [".", ".."]) names - forM properNames $ \name -> do + list <- forM properNames $ \name -> do let path = dir </> name - isDirectory <- doesDirectoryExist path + isDirectory <- runIO (doesDirectoryExist path) if (not isDirectory) && (".html" `isSuffixOf` name) then f path name - else return () + else return [] + return (concat list) + +generateTemplates :: String -> Q [Dec] +generateTemplates dir = searchTemplates dir workTemplate -workTemplate h path name = do - hPutStrLn stderr $ "Parsing "++name++"..." - contents <- readFile path +workTemplate :: String -> String -> Q [Dec] +workTemplate path name = do + runIO $ hPutStrLn stderr $ "Parsing "++name++"..." + contents <- runIO (readFile path) let res = parseTemplate name contents case res of - Left e -> hPutStrLn stderr (show e) - Right tpl -> do -- hPutStrLn stderr $ show res - hPutStr h $ genTemplate name tpl - -main = do args <- getArgs - tpls <- openFile (args!!1) WriteMode - preamble tpls - searchTemplates (head args) (workTemplate tpls) - endrender tpls - hClose tpls + Left e -> fail (show e) + Right tpl -> genTemplate tpl diff --git a/Framework/TGenerator/TemplateParser.hs b/Framework/TGenerator/TemplateParser.hs index 9519a84..7d1ed27 100644 --- a/Framework/TGenerator/TemplateParser.hs +++ b/Framework/TGenerator/TemplateParser.hs @@ -1,7 +1,7 @@ -- | Parser for templates -module TemplateParser - (Format (..), Template, - parseTemplate) +module Framework.TGenerator.TemplateParser +-- (Format (..), Template, +-- parseTemplate) where import Data.Char @@ -9,6 +9,8 @@ import Data.String.Utils import Text.ParserCombinators.Parsec import qualified Text.ParserCombinators.Parsec.Token as P import Text.ParserCombinators.Parsec.Language (haskellDef) +import Language.Haskell.Syntax +import Language.Haskell.TH -------------------------------------------------------------------------------------------------- -- Types @@ -24,6 +26,12 @@ data Format = Verbatim String type Template = [Format] +data TemplateFunction = TF { + templateName :: String, + templateType :: [(String, Type)], + templateBody :: Template } + deriving (Show) + -------------------------------------------------------------------------------------------------- -- Parser -------------------------------------------------------------------------------------------------- @@ -35,8 +43,70 @@ lexer = P.makeTokenParser haskellDef symbol :: String -> CharParser st String symbol = P.symbol lexer -parseTemplate :: SourceName -> String -> Either ParseError Template -parseTemplate = parse pTemplate +symbol' :: String -> Parser String +symbol' s = do + skipMany $ oneOf " \t" + x <- symbol s + skipMany $ oneOf " \t" + return x + +parseTemplate :: SourceName -> String -> Either ParseError TemplateFunction +parseTemplate = parse pTemplateFn + +pTemplateFn :: Parser TemplateFunction +pTemplateFn = do + (name, types) <- pSignature + skipMany $ oneOf " \t\r\n" + body <- pTemplate + return $ TF name types body + +pSignature :: Parser (String, [(String,Type)]) +pSignature = do + name <- many1 (noneOf " \t\r\n()") + skipMany $ oneOf " \t" + symbol' "(" + types <- (try pSgn) `sepBy1` (symbol ",") + symbol' ")" + return (name, types) + +pSgn :: Parser (String, Type) +pSgn = do + name <- many1 alphaNum + symbol' "::" + tp <- haskellType + return (name, tp) + +parseType :: String -> Type +parseType str = + case parse haskellType "" str of + Left e -> error $ show e + Right t -> t + +haskellType :: Parser Type +haskellType = try appType <|> try concreteType <|> try listType <|> parentedType + where + typeName = do + f <- oneOf "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + other <- many letter + skipMany $ oneOf " \t" + return (f:other) + + concreteType = do + name <- typeName + return $ ConT (mkName name) + + appType = do + f <- concreteType + tp <- haskellType + return $ f `AppT` tp + + listType = do + symbol "[" + tp <- haskellType + symbol "]" + return $ ListT `AppT` tp + + parentedType = between (symbol "(") (symbol ")") haskellType pTemplate :: GenParser Char st Template pTemplate = many1 (pVerbatim <|> (try pForTag) <|> (try pIfTag) <|> (try pIncludeVar) <|> (try pInclude) <|> (try pQuote))