>
> module Frame.GUI (
>
> GUI (..),
> Composable (..),
> Container (..),
> Class,
> URL,
> Element (..),
> Element' (..),
>
> 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
>
> data GUI
> = Frame String [URL] [Container]
> 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
>
> data Container
> = Panel [Container] [Class]
> | Paragraph [Element] [Class]
> | Code String
> | Quote [Container]
> | Header Int [Element]
> | List [[Container]] [Class]
> | NumList [[Container]] [Class]
> | Form [FormElement] [Class]
> | Error [Container]
> | 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
>
> type URL = String
> data Element
> = Element Element'
> | Link URL Element'
> | Strong [Element]
> | Emphasis [Element]
> | 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
> | Image URL String
> instance Show Element' where
> show (Image u s) = "<img src=\"" ++ u ++ "\" alt=\"" ++ s ++ "\" />"
> show (Text s) = s
>
> type Label = String
> data FormElement
> = FormGroup [FormElement] Label
> | TextField FieldName Label FormValue (Maybe Int) (Maybe Container)
> | HiddenField FieldName FormValue
> | TextArea FieldName Label FormValue (Maybe Container)
> | Button FieldName FormValue
> | ButtonLink Label URL
> 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 = ""
>
> type FormValue = WrapperType