View.lhs

> -- | High level view helpers
> module Frame.View (
>   module Frame.GUI,
>   module Frame.Data,
>   module Database.HaskellDB.BoundedList,
>   FrameView,
>   -- *** General,
>   (-.-),
>   title,
>   list,
>   errorList,
>   text,
>   link,
>   -- *** Forms
>   formGen,
>   form,
>   formField,
>   submitButton,
>   deleteLink,
>   cancelLink,
>   paragraph
> ) where

> import Database.HaskellDB.BoundedList
> import Database.HaskellDB.DBLayout hiding (fieldName)

> import Frame.Model
> import Frame.State
> import Frame.Config
> import Frame.GUI
> import Frame.Data
> import Frame.Types
> import Frame.Validation
> import Frame.Utilities

> class (FrameConfig m, FrameReader m) => FrameView m
> instance (FrameConfig m, FrameReader m) => FrameView m

> -- | Helper function for a submit button
> submitButton :: FormElement
> submitButton = Button "submit" $ WrapString Nothing "Submit"

> -- | Helper function for a delete link
> deleteLink :: URL         -- ^ Route for deletion
>            -> FormElement
> deleteLink u = ButtonLink "Delete" u

> -- | Helper function for a cancel link
> cancelLink :: URL         -- ^ Route for cancelation
>            -> FormElement
> cancelLink u = ButtonLink "Cancel" u

> -- | Helper function to create a single simple element paragraph
> paragraph :: Element  -- ^ Element
>           -> Container -- ^ Paragraph
> paragraph e = Paragraph [e] []

> singleton :: a -> [a]
> singleton l = [l]

> -- | Abstract list generator
> list :: (a -> Container) -- ^ List item generator
>      -> [a]              -- ^ Items
>      -> [Class]          -- ^ Classes
>      -> Container        -- ^ List
> list f as cs = List (map (singleton . f) as) cs

> -- | Creates element level text
> text :: String  -- ^ Text to use
>      -> Element -- ^ Element created
> text s = Element $ Text s

> -- | Creates a link with just a text element
> link :: URL     -- ^ URL to use
>      -> String  -- ^ Text to use
>      -> Element -- ^ The link
> link u s = Link u $ Text s

> -- | Helper function for generating a potential error list
> errorList :: [String]        -- ^ Errors
>           -> Maybe Container -- ^ Error list (if errors)
> errorList [] = Nothing
> errorList es = Just $ list (\e -> paragraph $ text e) es ["error"]

> -- | Helper function for creating a form field
> formField :: FieldName 
>           -> Label
>           -> FormValue   -- ^ Set value of field
>           -> Maybe Int   -- ^ Potential length restriction of the field
>           -> [String]    -- ^ List of errors
>           -> Bool        -- ^ Is the form field hidden?
>           -> FormElement -- ^ The field
> formField fn f v ml@(Just l) es False = if l <= 255 then TextField fn f v ml $ errorList es else TextArea fn f v $ errorList es
> formField fn f v Nothing es False = TextField fn f v Nothing $ errorList es
> formField fn f v _ _ True    = HiddenField fn v

> -- | Helper function to create a simple form with a single group
> form :: Label         -- ^ Group label
>      -> [FormElement] -- ^ Form elements
>      -> [String]      -- ^ Any classes
>      -> Container     -- ^ The form
> form l es cs = Form [
>                   FormGroup es l
>                ] cs

> -- | Generates a form based on a database description
> formGen :: FrameView m => (Table r) -- ^ The table for which the form will be gotten
>         -> [FormElement]            -- ^ A set of form elements to append to the form
>         -> [String]                 -- ^ A set of form fields to hide/not display
>         -> m Container              -- ^ The form
> formGen t es hs = do 
>        db <- asks database
>        n <- asks dbName
>        formGen' es hs n (tableName t) db

> formGen' :: FrameView m => [FormElement] -> [String] -> String -> String -> DBInfo -> m Container
> formGen' es hs d t (DBInfo {dbname=n, tbls=ts}) 
>              = if (d == n) then 
>                    formGenTbl es hs d t ts 
>                else 
>                    return $ paragraph $ text "Database not found"

> formGenTbl :: FrameView m => [FormElement] -> [String] -> String -> String -> [TInfo] -> m Container
> formGenTbl es hs d t [] = return $ paragraph $ text "Table not found"
> formGenTbl es hs d t ((TInfo {tname=tn, cols=cs}):ts) 
>              = if (t == tn) then 
>                    do 
>                       cs <- formGenCol hs d t cs
>                       return $ form t (cs ++ es) [t]
>                else 
>                    formGenTbl es hs d t ts

> formGenCol :: FrameView m => [String] -> String -> String -> [CInfo] -> m [FormElement]
> formGenCol hs d t [] = return []
> formGenCol hs d t ((CInfo {cname=n, descr=(ty,_)}):cs') = do 
>    cs <- formGenCol hs d t cs'
>    mf <- getField $ fieldName t n
>    mv <- getValidator $ fieldName t n
>    case mf of
>        Just f -> return $ (formField (fieldName t n) (humaniseCamel n) f (maxLen ty) (errors mv f) $ hide n):cs 
>        Nothing -> return $ if hide n then cs else (formField (fieldName t n) (humaniseCamel n) (WrapEmpty StringT) (maxLen ty) [] False):cs
>    where
>      errors (Just v) f = map fromJust $ filter isJust $ validateField v f
>      errors Nothing _  = []
>      maxLen (BStrT n) = Just n
>      maxLen _         = Nothing
>      hide n = elem (fieldName t n) $ (fieldName t "id"):hs

> -- | The 'title' function wraps a ViewPart in a View if not an Ajax request
> title :: FrameView m 
>       => String -- ^ The title of the View
>       -> m Data -- ^ The ViewPart to wrap
>       -> m Data -- ^ The resulting Data type
> title t d = do 
>       a <- gets ajax
>       c <- asks css
>       case a of
>          True  -> d
>          False -> do 
>             d' <- d
>             return $ title' t c d'

> title' :: String -> [String] -> Data -> Data
> title' t c (ViewPart cs) = View $ Frame t c cs
> title' _ _ d = d