frame-0.1: 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