src/Frame/GUI.lhs

> {-|
>     A subset of the GUI required to build a useful view
> -}
> module Frame.GUI (
>   -- * GUI
>   GUI (..),
>   Composable (..),
>   Container (..),
>   Class,
>   URL,
>   Element (..),
>   Element' (..),
>   -- ** Forms
>   Label,
>   FormElement (..),
>   FormValue,
> ) where

> import Frame.Utilities
> import Database.HaskellDB.DBLayout
> import Frame.Types

> class Composable a where
>   (<+) :: a -> Container -> a
>   (+>) :: Container -> a -> a

> type Class = String

> -- |  A generic GUI whose various instances define how it should be output (e.g. Show outputs HTML).
> data GUI 
>      = Frame String [URL] [Container] -- ^ A frame with a title, some style and a set of containers

> instance Composable GUI where
>  (Frame t s cs) <+ c = Frame t s $ cs ++ [c]
>  c +> (Frame t s cs) = Frame t s $ c:cs

> instance Show GUI where
>     show (Frame t s cs) = "<html>\n\t<head>\n\t\t<title>" ++ 
>                                t ++ "</title>\n\t" ++ showCSS s ++ "<body>\n" ++ 
>                                concatMap show cs ++ 
>                                "\n\t</body>\n</html>"

> showCSS :: [String] -> String
> showCSS []     = ""
> showCSS (c:cs) = "<link rel=\"stylesheet\" href=\"" ++ c ++ "\" type=\"text/css\" />\n\t</head>\n\t" ++ showCSS cs

> -- | Contains various 'block level' elements
> data Container 
>      = Panel [Container] [Class]     -- ^ Panel matches up with a div when output as HTML
>      | Paragraph [Element] [Class]   -- ^ Paragraphs can only only contain elements
>      | Code String                   -- ^ Code
>      | Quote [Container]             -- ^ Quote
>      | Header Int [Element]          -- ^ Header (int is size)
>      | List [[Container]] [Class]    -- ^ Lists contain list items
>      | NumList [[Container]] [Class] -- ^ Lists contain list items
>      | Form [FormElement] [Class]    -- ^ A form
>      | Error [Container]-- ^ Error pane
>      | Line
>      | Empty

> instance Composable Container where
>  (Panel cs s) <+ c = Panel (cs ++ [c]) s
>  (Quote cs) <+ c = Quote (cs ++ [c])
>  (List css s) <+ c = List (css ++ [[c]]) s
>  (NumList css s) <+ c = NumList (css ++ [[c]]) s
>  (Error cs) <+ c = Error (cs ++ [c])
>  c <+ c' = Panel (c:[c']) []
>  c +> (Panel cs s) = Panel (c:cs) s
>  c +> (Quote cs) = Quote (c:cs)
>  c +> (List css s) = List ([c]:css) s
>  c +> (NumList css s) = NumList ([c]:css) s
>  c +> (Error cs) = Error (c:cs)
>  c' +> c = Panel (c:[c']) []

> instance Show Container where
>     show (Panel cs c) = "<div" ++ showClass c ++ ">" ++ concatMap show cs ++ "</div>"
>     show (Paragraph es c) = "<p" ++ showClass c ++ ">" ++ concatMap show es ++ "</p>" 
>     show (Code s) = "<code>" ++ s ++ "</code>" 
>     show (Quote cs) = "<blockquote>" ++ concatMap show cs ++ "</blockquote>" 
>     show (Header s es) = "<h" ++ show s ++ ">" ++ concatMap show es ++ "</h" ++ show s ++ ">" 
>     show (List is c) = "<ul" ++ showClass c ++ ">" ++ concatMap showListItem is ++ "</ul>"
>     show (NumList is c) = "<ol" ++ showClass c ++ ">" ++ concatMap showListItem is ++ "</ol>"
>     show (Form fs c) = "<form" ++ showClass c ++ " method=\"post\">" ++ concatMap show fs ++ "</form>"
>     show (Error s) = "<div class=\"error\">" ++ concatMap show s ++ "</div>"
>     show Line = "<hr />"
>     show Empty = ""

> showClass :: [String] -> String
> showClass [] = ""
> showClass cs = " class=\"" ++ showClasses cs ++ "\""
> showClasses :: [String] -> String
> showClasses [c]    = c
> showClasses (c:cs) = c ++ " " ++ showClasses cs

> showListItem :: [Container] -> String
> showListItem cs = "\n\t\t<li>" ++ concatMap show cs ++ "</li>"

Some canonical types for URLs and Labels

> -- | A URL
> type URL           = String

> data Element       
>      = Element Element'   -- ^ Plain element
>      | Link URL Element'  -- ^ Element wrapped in a link
>      | Strong [Element]   -- ^ Element wrapped in a link
>      | Emphasis [Element] -- ^ Element wrapped in a link
>      | Break              -- ^ Line break

> instance Show Element where
>     show (Link u e)  = "<a href=\"" ++ u ++ "\">" ++ show e ++ "</a>"
>     show (Strong es)  = "<strong>" ++ concatMap show es ++ "</strong>"
>     show (Emphasis es)  = "<em>" ++ concatMap show es ++ "</em>"
>     show (Element e) = show e
>     show Break       = "<br />"

> data Element'      
>      = Text String      -- ^ Textual element
>      | Image URL String -- ^ Image element

> instance Show Element' where
>     show (Image u s) = "<img src=\"" ++ u ++ "\" alt=\"" ++ s ++ "\" />" 
>     show (Text s) = s

> -- | A label
> type Label         = String

> data FormElement   
>      = FormGroup [FormElement] Label                                     -- ^ For grouping elements
>      | TextField FieldName Label FormValue (Maybe Int) (Maybe Container) -- ^ Standard text box
>      | HiddenField FieldName FormValue                                   -- ^ Hidden field
>      | TextArea FieldName Label FormValue (Maybe Container)              -- ^ Larger text box
>      | Button FieldName FormValue                                        -- ^ Submit button
>      | ButtonLink Label URL                                              -- ^ Special textual button

> instance Show FormElement where
>     show (FormGroup es l) = "<fieldset>" ++ ((length l == 0) ?? ("<legend>" ++ l ++ "</legend>")) ++ "<ul>" ++ concatMap show es ++  "</ul></fieldset>"
>     show (TextField fn l fv ml (Just e)) = "<li class=\"error\">" ++ show e ++ "<label for=\"" ++ fn ++ "\">" ++ l ++ "</label><input type=\"text\" name=\"" ++ fn ++ "\" value=\"" ++ show fv ++ "\"" ++ showMaxLength ml ++ " /></li>"
>     show (TextField fn l fv ml Nothing) = "<li><label for=\"" ++ fn ++ "\">" ++ l ++ "</label><input type=\"text\" name=\"" ++ fn ++ "\" value=\"" ++ show fv ++ "\"" ++ showMaxLength ml ++ " /></li>"
>     show (HiddenField l fv) = "<input type=\"hidden\" name=\"" ++ l ++ "\" value=\"" ++ show fv ++ "\" />"
>     show (TextArea l t fv (Just e)) = "<li class=\"error\">" ++ show e ++ "<label for=\"" ++ l ++ "\">" ++ t ++ "</label><textarea name=\"" ++ l ++ "\">" ++ show fv ++ "</textarea></li>"
>     show (TextArea l t fv Nothing) = "<li><label for=\"" ++ l ++ "\">" ++ t ++ "</label><textarea name=\"" ++ l ++ "\">" ++ show fv ++ "</textarea></li>"
>     show (Button l fv) = "<li><input type=\"submit\" name=\"" ++ l ++ "\" value=\"" ++ show fv ++ "\" /></li>"
>     show (ButtonLink l u) = "<li><a href=\"" ++ u ++ "\">" ++ l ++ "</a></li>"

> showMaxLength :: Maybe Int -> String
> showMaxLength (Just i) = " maxlength=\"" ++ show i ++ "\""
> showMaxLength Nothing  = ""

> -- | Form values are just wrapped types
> type FormValue     = WrapperType