diff --git a/.gitignore b/.gitignore index 8a5e822..f7cc75c 100644 --- a/.gitignore +++ b/.gitignore @@ -14,4 +14,4 @@ html/* tags *.hcr *.mo - +*.log diff --git a/Blog/Extensions/Handlers.hs b/Blog/Extensions/Handlers.hs index 0b7c058..d0922d9 100644 --- a/Blog/Extensions/Handlers.hs +++ b/Blog/Extensions/Handlers.hs @@ -5,6 +5,7 @@ import Network.URI import Framework.Types import Framework.Controller +import Framework.TEngine.Types import Framework.TEngine.TemplateUtil import Framework.Modules.Auth.Handlers diff --git a/Blog/Models.hs b/Blog/Models.hs index 4ba0958..fbc83da 100644 --- a/Blog/Models.hs +++ b/Blog/Models.hs @@ -6,6 +6,7 @@ module Models where import qualified Data.Map as M import Framework.Types +import Framework.TEngine.Types import Framework.Forms.Types import Framework.Forms.HTML import Framework.Forms.Validators diff --git a/Framework/API.hs b/Framework/API.hs index 7835553..ad86280 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -26,6 +26,7 @@ module Framework.API module Framework.API.Logger, module Framework.API.UserMessage, -- ** Specific modules + module Framework.TEngine.Types, module Framework.TEngine.TemplateUtil, module Framework.Forms.Rendering, module Framework.Pager, @@ -56,6 +57,7 @@ import Framework.API.CRUD import Framework.API.Logger import Framework.API.UserMessage +import Framework.TEngine.Types import Framework.TEngine.TemplateUtil import Framework.Forms.Rendering import Framework.Pager diff --git a/Framework/API/CRUD.hs b/Framework/API/CRUD.hs index 52847d9..bc8f464 100644 --- a/Framework/API/CRUD.hs +++ b/Framework/API/CRUD.hs @@ -1,3 +1,4 @@ +-- | This module supplies simple create / update / delete controllers module Framework.API.CRUD where import Control.Monad.Reader.Class @@ -20,7 +21,19 @@ import Framework.Forms.ModelForm import Framework.GetText.Controller import Framework.TEngine.TemplateUtil -create' :: Model -> Form -> [SqlValue] -> String -> AController (String,String) +{- | Controller for creating a Model + +Sample usage: + +> controller = do +> (form,err) <- create' someModel someForm [] "/url" +> renderToResponseM "template.html" [("form", C form), ("invalid", C err)] +-} +create' :: Model -- ^ Model to create + -> Form -- ^ Form to display + -> [SqlValue] -- ^ Additional params (which are no in form) + -> String -- ^ Where to redirect after creation + -> AController (String,String) -- ^ (Form HTML, error message) create' model form params target = do rq <- asks request let url = myUrl rq @@ -32,10 +45,23 @@ create' model form params target = do message $ printf msg (capitalize $ mName model) returnNow $ redirect target +-- | Same, but use modelForm as form create :: Model -> [SqlValue] -> String -> AController (String,String) create model params target = create' model (modelForm model) params target -update' :: Model -> Form -> Int -> String -> AController (String,String) +{- | Controller to edit the Model + +Sample usage: + +> controller = do +> (form,err) <- update' someModel someForm oid "/url" +> renderToResponseM "template.html" [("form", C form), ("invalid", C err)] +-} +update' :: Model -- ^ Model to edit + -> Form -- ^ Form to display + -> Int -- ^ Object ID + -> String -- ^ Where to redirect after edit + -> AController (String,String) -- ^ (Form HTML, error message) update' model form oid target = do rq <- asks request let url = myUrl rq @@ -49,10 +75,24 @@ update' model form oid target = do message $ printf msg (capitalize $ mName model) returnNow $ redirect target +-- | Same, but use modelForm as form update :: Model -> Int -> String -> AController (String,String) update model oid target = update' model (modelForm model) oid target -delete :: Model -> Int -> String -> AController () +{- | Controller to delete a Model from DB + +Sample usage: + +> controller = do +> delete someModel oid "/url" +> renderToResponseM "template.html" [] + +Template should contain a form or link to set GET or POST variable confirm=yes. +-} +delete :: Model -- ^ Model to delete + -> Int -- ^ Object ID + -> String -- ^ Where to redirect afrer deletion + -> AController () delete model oid target = do rq <- asks request let url = myUrl rq diff --git a/Framework/API/SQL.hs b/Framework/API/SQL.hs index df922ae..edb76ee 100644 --- a/Framework/API/SQL.hs +++ b/Framework/API/SQL.hs @@ -39,6 +39,9 @@ querySQL' q params model = do conn <- asks dbconnection liftIO $ Storage.queryR' conn (sql q) params model +-- | Select related (children) records for each model in the list. +-- This will do one DB query for each list item. +-- After this, templates can use @children@ function. selectRelated :: [Model] -> AController [Model] selectRelated models = do forM models $ \m -> do diff --git a/Framework/API/SQLUtils.hs b/Framework/API/SQLUtils.hs index 8803c52..76235eb 100644 --- a/Framework/API/SQLUtils.hs +++ b/Framework/API/SQLUtils.hs @@ -24,8 +24,9 @@ getOneObject model oid = do assertC $ (length objs)==1 return $ head objs -insertModel :: Model - -> Form +-- | Create new Model in DB, get fields from request +insertModel :: Model -- ^ Model to create + -> Form -- ^ Displayed form -> String -- ^ Form ID -> [HDBC.SqlValue] -- ^ Additional fields (which are not in form) -> AController () @@ -43,6 +44,7 @@ insertModel model form fid params = do values = map (obj -:>) fields Left e -> returnInvalidForm form' fid e +-- | Update a model in DB, get fields from request updateModel :: Model -- ^ Model -> Form -> String -- ^ Form ID @@ -63,6 +65,10 @@ updateModel model form fid oid = do values = map (obj -:>) fields Left e -> returnInvalidForm form' fid e +-- | Delete a model from DB +deleteModel :: Model -- ^ Model to delete + -> Int -- ^ Object ID + -> AController () deleteModel model oid = do send "pre_delete" model queryListSQL' (deleteM model (pk:==:"?")) [HDBC.toSql oid] diff --git a/Framework/ContextProcessors.hs b/Framework/ContextProcessors.hs index 603b7e8..437367d 100644 --- a/Framework/ContextProcessors.hs +++ b/Framework/ContextProcessors.hs @@ -6,6 +6,7 @@ module Framework.ContextProcessors import Control.Monad.Reader.Class import Framework.Types +import Framework.TEngine.Types import Framework.Utils import Framework.Controller import Framework.API.Sessions diff --git a/Framework/Controller.hs b/Framework/Controller.hs index 04238f5..036af16 100644 --- a/Framework/Controller.hs +++ b/Framework/Controller.hs @@ -30,6 +30,7 @@ import Control.Monad.State.Class import Control.Monad.Trans import Framework.Types +import Framework.TEngine.Types --------------------------------------------------------------------------------------- -- * Data types diff --git a/Framework/Http/Vars.hs b/Framework/Http/Vars.hs index 745f00c..238dd3e 100644 --- a/Framework/Http/Vars.hs +++ b/Framework/Http/Vars.hs @@ -1,4 +1,13 @@ --- | This module contains functions to access HTTP GET and POST variables. +{- | This module contains functions to access HTTP GET and POST variables. + +HTTP vars can be accessed in three ways. + +I. If you need to get/set only several variables, you can use @httpGetVar@ and its family. That requires @HttpRequest@ as argument. + +II. If you need this in controller, it's simpler to use @_GET@ and its family. That is used as argument for @asks@. + +III. If you need to get/set many HTTP variables, it's better to fetch a variables map (with @getvars@ or @postvars@), and work with it (with @getString@ or @getFile@). +-} module Framework.Http.Vars (_GET, _GET', _POST, _POST', getvars, postvars, @@ -22,16 +31,30 @@ import Framework.Utils import Framework.Http.Httpd import Framework.Http.PostParser +{- | Get value of GET variable. Sample usage in controller: + +> controller = do +> var <- asks (_GET "varname") +-} _GET :: String -> ActionConfig -> String _GET name ac = _GET' name "" ac +-- | Get value of POST variable (see notes for @_GET@) _POST :: String -> ActionConfig -> String _POST name ac = _POST' name "" ac -_GET' :: String -> String -> ActionConfig -> String +-- | Same as @_GET@, but with default value +_GET' :: String -- ^ Var name + -> String -- ^ Default value + -> ActionConfig + -> String _GET' name def ac = httpGetVar' (request ac) name def -_POST' :: String -> String -> ActionConfig -> String +-- | Same as @_POST@, but with default value +_POST' :: String -- ^ Var name + -> String -- ^ Default value + -> ActionConfig + -> String _POST' name def ac = httpPostVar' (request ac) name def -- | Get map of GET variables from request diff --git a/Framework/Modules/Auth/Context.hs b/Framework/Modules/Auth/Context.hs index b67f5ac..6899589 100644 --- a/Framework/Modules/Auth/Context.hs +++ b/Framework/Modules/Auth/Context.hs @@ -5,6 +5,7 @@ module Framework.Modules.Auth.Context where import Control.Monad.Reader.Class import Framework.Types +import Framework.TEngine.Types import Framework.Controller import Framework.Utils diff --git a/Framework/Modules/Auth/Models.hs b/Framework/Modules/Auth/Models.hs index 4333260..57aaa5e 100644 --- a/Framework/Modules/Auth/Models.hs +++ b/Framework/Modules/Auth/Models.hs @@ -1,7 +1,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} module Framework.Modules.Auth.Models where -import Framework.Types +import Framework.TEngine.Types import Framework.Forms.Types import Framework.Forms.HTML import Framework.Forms.Validators diff --git a/Framework/Modules/Registration/Context.hs b/Framework/Modules/Registration/Context.hs index 8ad80d8..fe18f24 100644 --- a/Framework/Modules/Registration/Context.hs +++ b/Framework/Modules/Registration/Context.hs @@ -3,6 +3,7 @@ module Framework.Modules.Registration.Context where import Control.Monad.Reader.Class import Framework.Types +import Framework.TEngine.Types import Framework.Controller import Framework.Utils diff --git a/Framework/ORM/Models.hs b/Framework/ORM/Models.hs index 7a7c40f..41debc6 100644 --- a/Framework/ORM/Models.hs +++ b/Framework/ORM/Models.hs @@ -16,6 +16,7 @@ import qualified Data.Convertible.Base as CD import Database.HDBC (SqlValue(..), fromSql) import Framework.Types +import Framework.TEngine.Types import Framework.ORM.Types emptyModel :: Model diff --git a/Framework/Pool.hs b/Framework/Pool.hs index 9242be1..f1dbbf8 100644 --- a/Framework/Pool.hs +++ b/Framework/Pool.hs @@ -1,10 +1,14 @@ {-# LANGUAGE TypeSynonymInstances #-} --- | This module describes an abstract pool of any `connections` (to DB, cache backend or anything). One will create a pool with --- pool <- emptyPool 20 --- (that opens 20 connections), and then --- (idx, pool) <- acquire someConfig connectFunction -- Get open connection or create a new one --- doSomethingWith conn --- free pool idx conn -- Free a connection, so it may be used again by other threads +{- | This module describes an abstract pool of any `connections` (to DB, cache backend or anything). One will create a pool with + +> pool <- emptyPool 20 + +(that opens 20 connections), and then + +> (idx, pool) <- acquire someConfig connectFunction -- Get open connection or create a new one +> doSomethingWith conn +> free pool idx conn -- Free a connection, so it may be used again by other threads +-} module Framework.Pool (Pool, MPool, emptyPool, diff --git a/Framework/TEngine/TemplateFuncs.hs b/Framework/TEngine/TemplateFuncs.hs index 6136b80..df6d3bd 100644 --- a/Framework/TEngine/TemplateFuncs.hs +++ b/Framework/TEngine/TemplateFuncs.hs @@ -5,13 +5,14 @@ module Framework.TEngine.TemplateFuncs evenP,oddP, list, separateWith, children, - pager + mapF, isContainerTrue ) where import Data.Char import Data.List +import qualified Data.Map as M -import Framework.Types +import Framework.TEngine.Types import qualified Framework.Pager as Pager bold :: Maybe TContainer -> String @@ -30,19 +31,28 @@ evenP = apply (even::Int -> Bool) oddP :: Maybe TContainer -> Bool oddP = apply (odd::Int -> Bool) -list :: String -> (String -> String) -> Maybe TContainer -> String +-- | 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 -children :: String -> TContainer -> TContainer +-- | 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 -> TContainer -- ^ Page number @@ -55,3 +65,18 @@ pager (C lst) (C url) (C p) = Pager.genpager url' pages p' itemCount = length $ mkList lst perpage = n $ head $ mkList lst 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 + diff --git a/Framework/TEngine/TemplateUtil.hs b/Framework/TEngine/TemplateUtil.hs index 6dbf29d..2f04dd9 100644 --- a/Framework/TEngine/TemplateUtil.hs +++ b/Framework/TEngine/TemplateUtil.hs @@ -12,6 +12,7 @@ import qualified Data.Map as M import Framework.Http.Response (ok) import Framework.TEngine.Templates (render) import Framework.Types +import Framework.TEngine.Types import Framework.Controller import Framework.API.Sessions import Framework.API.Cache diff --git a/Framework/TEngine/Types.hs b/Framework/TEngine/Types.hs new file mode 100644 index 0000000..51940fb --- /dev/null +++ b/Framework/TEngine/Types.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE ExistentialQuantification, RankNTypes, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, TypeSynonymInstances, UndecidableInstances, ImpredicativeTypes, ScopedTypeVariables, IncoherentInstances #-} +module Framework.TEngine.Types where + +import Data.List + +-- | Single item to render in template. +class TemplateOne a where + -- | Show + showO :: a -> String + -- | Get n'th integer field + intField :: Int -> a -> Int + -- | Get n'th string field + stringField :: Int -> a -> String + -- | Get n'th boolean field + boolField :: Int -> a -> Bool + + -- | Get assoc.list of related models + getRelated :: a -> [(String,[a])] + getRelated _ = [] + -- | 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/TemplateGen.hs b/Framework/TGenerator/TemplateGen.hs index 80feb55..579ae12 100644 --- a/Framework/TGenerator/TemplateGen.hs +++ b/Framework/TGenerator/TemplateGen.hs @@ -63,20 +63,18 @@ genTemplate name tpl = if name=="0" joinList lst = concat $ intersperse ",\n" $ map (" "++) $ map quote lst quoteLines s = joinList $ map (replace "\"" "\\\"") $ lines s -undollars = unwords - genquote xs = if null fs then getvar x - else "("++(undollars fs)++") (M.lookup "++(quote x)++" pairs)" + else "("++(unwords fs)++") (M.lookup "++(quote x)++" pairs)" where fs = init xs x = last xs genquoteB xs = if null fs - then "isTrue `bmap` (M.lookup "++(quote x)++" pairs)" - else "("++(undollars fs)++") (M.lookup "++(quote x)++" pairs)" + then "isContainerTrue (M.lookup "++(quote x)++" pairs)" + else "("++(unwords fs)++") (M.lookup "++(quote x)++" pairs)" where fs = init xs x = last xs @@ -97,8 +95,8 @@ preamble h = do hPutStrLn h "module Framework.TEngine.Templates where" hPutStrLn h "import qualified Data.Map as M" hPutStrLn h "import Data.List" - hPutStrLn h "import Framework.Types" hPutStrLn h "import Framework.Utils" + hPutStrLn h "import Framework.TEngine.Types" hPutStrLn h "import Framework.TEngine.TemplateFuncs" hPutStrLn h "import Models" hPutStrLn h "" diff --git a/Framework/Types.hs b/Framework/Types.hs index e2aa27a..173d422 100644 --- a/Framework/Types.hs +++ b/Framework/Types.hs @@ -115,218 +115,3 @@ instance Show Log where show _ = "<Log channel>" ------------------------------------------------------------------------------------------- - --- | Single item to render in template. -class TemplateOne a where - -- | Show - showO :: a -> String - -- | Get n'th integer field - intField :: Int -> a -> Int - -- | Get n'th string field - stringField :: Int -> a -> String - -- | Get n'th boolean field - boolField :: Int -> a -> Bool - - -- | Get assoc.list of related models - getRelated :: a -> [(String,[a])] - getRelated _ = [] - -- | 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 = concat $ intersperse ", " (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 = concat $ intersperse ", " (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 - --- | String function of "TContainer" -type SFunction = forall a. (TemplateItem a) => a -> String - --- | Boolean function of "TContainer" -type BFunction = forall a. (TemplateItem a) => a -> Bool - -------------------------------------------------------------------------------------------- -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 - --- | 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)] - --- | Apply "BFunction" to content of TContainer -bmap :: BFunction -> Maybe TContainer -> Bool -bmap f x = maybe False id $ bmap' `fmap` x - where bmap' :: TContainer -> Bool - bmap' (C y) = f y - -transformInts :: (TemplateOne a) => Int -> (Int -> b) -> a -> [b] -transformInts n f = \x -> f `map` (intFields n x) - -transformStrings :: (TemplateOne a) => Int -> (String -> b) -> a -> [b] -transformStrings n f = \x -> f `map` (stringFields n x) - -transformBools :: (TemplateOne a) => Int -> (Bool -> b) -> a -> [b] -transformBools n f = \x -> f `map` (boolFields n x) - -transformInt :: (TemplateOne a) => Int -> (Int -> t) -> a -> t -transformInt n f = \x -> f (intField n x) - -transformString :: (TemplateOne a) => Int -> (String -> t) -> a -> t -transformString n f = \x -> f (stringField n x) - -transformBool :: (TemplateOne a) => Int -> (Bool -> t) -> a -> t -transformBool n f = \x -> f (boolField n x) -------------------------------------------------------------------------------------------- -